home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / ab20 / aplictns / analyclc.lzh / Analy.For < prev    next >
Text File  |  1990-08-28  |  629KB  |  22,578 lines
  1. c ********** ANALYAC.FTN ##########################################
  2. C This version of AnalytiCalc uses the include file AParms.inc to
  3. C contain parameters. These specify the "prime area" of the
  4. C spreadsheet, and also the size of in-memory buffers that
  5. C are used for in-memory storage of spreadsheet data. Larger
  6. C spreadsheets may of course be stored using the software
  7. C paging built in, but at much reduced speed.
  8. C  Glenn Everhart 9/20/1989
  9. C
  10. C parameter relationships implicit below:
  11. C mval, nominal 800, multiple of 100
  12. C mfrm, nominal 2048, multiple of 128
  13. C Mvlov2=mval/2
  14. C mfrmo2=mfrm/2
  15. C MVal/16=mvlo16
  16. C mfrm/64=mfro64
  17. c -h- analy.for    Fri Aug 22 12:54:45 1986    
  18.        PROGRAM ANALY(INPUT=15,OUTPUT=16,TAPE=17,ERR=1)
  19. C ANALYTICALC MAIN PROGRAM
  20. C SPREAD SHEET DRIVER PROGRAM
  21.     Include aparms.inc
  22. C COPYRIGHT (C) 1983-1990 GLENN AND MARY EVERHART
  23. C ALL RIGHTS RESERVED
  24. C MAX SHEET DIMS ARE MCOLS BY mrows-1 (MROWS SINCE ACCUMULATORS ARE A PSEUDO ROW)
  25. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  26. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  27. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  28. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  29. C FROM THE DISK BASED FILE HERE.
  30. C
  31.     InTeGer*4 PRL(6)
  32.         CHARACTER*1 NOWRAP ( 2 )
  33.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  34.     INTEGER*4 VNLT
  35.     INTEGER IFCW
  36. C    EXTERNAL LCWRQQ
  37.     DIMENSION FORM(128),FVLD(1,1)
  38. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  39. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  40. C SO INITIALLY IGNORE.
  41. C
  42. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  43. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  44. C
  45. C ***<<<< RDD COMMON START >>>***
  46.     InTeGer*4 RRWACT,RCLACT
  47. C    COMMON/RCLACT/RRWACT,RCLACT
  48.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  49.      1  IDOL7,IDOL8
  50. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  51. C     1  IDOL7,IDOL8
  52.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  53. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  54.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  55. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  56. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  57. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  58.     InTeGer*4 KLVL,k3dfg,kcdelt,krdelt,kpag
  59. C    COMMON/KLVL/KLVL
  60.     InTeGer*4 IOLVL,igold
  61. C    COMMON/IOLVL/IOLVL
  62. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  63. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  64.     Integer*4 Idsptp,Idol9
  65.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  66.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  67.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  68.      3  k3dfg,kcdelt,krdelt,kpag
  69. C ***<<< RDD COMMON END >>>***
  70.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  71.     COMMON/D2R/NRDSP,NCDSP
  72.     InTeGer*4 TYPE(1,1),VLEN(9)
  73.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  74.     REAL*8 XXV(1,1)
  75.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  76.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  77. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  78.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  79.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  80.     CHARACTER*12 CDVFMT
  81.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  82.     COMMON/DEFVBX/DVFMT
  83.     CHARACTER*1 NMSH(80)
  84.     CHARACTER*80 NMSH80
  85.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  86.     COMMON/NMSH/NMSH
  87.     CHARACTER*1 FORM2(4)
  88. C ***<<< XVXTCD COMMON START >>>***
  89.     CHARACTER*1 OARRY(100)
  90.     InTeGer*4 OSWIT,OCNTR
  91. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  92. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  93.     InTeGer*4 IPS1,IPS2,MODFLG
  94. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  95.        InTeGer*4 XTCFG,IPSET,XTNCNT
  96.        CHARACTER*1 XTNCMD(80)
  97. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  98. C VARY FLAG ITERATION COUNT
  99.     INTEGER KALKIT
  100. C    COMMON/VARYIT/KALKIT
  101.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  102.     InTeGer*4 RCMODE,IRCE1,IRCE2
  103. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  104. C     1  IRCE2
  105. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  106. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  107. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  108. C RCFGX ON.
  109. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  110. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  111. C  AND VM INHIBITS. (SETS TO 1).
  112.     INTEGER*4 FH
  113. C FILE HANDLE FOR CONSOLE I/O (RAW)
  114. C    COMMON/CONSFH/FH
  115.     CHARACTER*1 ARGSTR(52,4)
  116. C    COMMON/ARGSTR/ARGSTR
  117.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  118.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  119.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  120.      3  IRCE2,FH,ARGSTR
  121. C ***<<< XVXTCD COMMON END >>>***
  122. C
  123. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  124. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  125. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  126. C DISPLAY ACTUALLY USED FOR SCREEN.
  127.     InTeGer*4 CWIDS(20)
  128. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  129. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  130. C AS 20 NOT 75.
  131.     INTEGER*4 I4TMP
  132.     REAL*8 DVS(20,75)
  133.     COMMON /FVLDC/FVLD
  134. C FOLLOWING SUPPORT VVARY OVERLAY:
  135.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  136.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  137.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  138. C BITMAP
  139. C    CHARACTER*1 IBITMP
  140. C    DIMENSION IBITMP(2258)
  141. C    COMMON/INITD/IBITMP
  142. C    CHARACTER*1 DFMTS(10,20,75)
  143. C 10 CHARACTERS PER ENTRY.
  144.     COMMON/DSPCMN/DVS,CWIDS
  145. C    character*35 fwt
  146. C COMMONS FROM OTHER MISC. ROUTINES, ADDED TO ALLOW AMIGA FORTRAN TO
  147. C ALLOCATE COMMONS ON STACK...
  148.     CHARACTER*1 LBITS(8)
  149.     COMMON/BITS/LBITS
  150.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  151.     COMMON/CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  152.     CHARACTER*1 DTBL1(9,9,8)
  153.     COMMON/DECIDE/DTBL1
  154.     CHARACTER*1 DIGITS(16,3)
  155.     COMMON/DIGV/DIGITS
  156. C ***<<< KLSTO COMMON START >>>***
  157.     InTeGer*4 DLFG
  158. C    COMMON/DLFG/DLFG
  159.     InTeGer*4 KDRW,KDCL
  160. C    COMMON/DOT/KDRW,KDCL
  161.     InTeGer*4 DTRENA
  162. C    COMMON/DTRCMN/DTRENA
  163.     REAL*8 EP,PV,FV
  164.     DIMENSION EP(20)
  165.     INTEGER*4 KIRR
  166. C    COMMON/ERNPER/EP,PV,FV,KIRR
  167.     InTeGer*4 LASTOP
  168. C    COMMON/ERROR/LASTOP
  169.     CHARACTER*1 FMTDAT(9,76)
  170. C    COMMON/FMTBFR/FMTDAT
  171.     CHARACTER*1 EDNAM(16)
  172. C    COMMON/EDNAM/EDNAM
  173.     InTeGer*4 MFID(2),MFMOD(2)
  174. C    COMMON/FRM/MFID,MFMOD
  175.     InTeGer*4 JMVFG,JMVOLD
  176. C    COMMON/FUBAR/JMVFG,JMVOLD
  177.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  178.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  179. C ***<<< KLSTO COMMON END >>>***
  180. C
  181. C
  182.         CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
  183.     CHARACTER*1 FVXX(Imps3)
  184.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  185.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  186.         Common/FVLDM/FVXX
  187. c        COMMON/FVLDM/FV1,FV2,FV4
  188.     InTeGer*2 IFID(8,MFrm)
  189.     COMMON/IFIDC/IFID
  190.     InTeGer*4 ILNFG,ILNCT
  191.     CHARACTER*1 ILINE(106)
  192.     COMMON/ILN/ILNFG,ILNCT,ILINE
  193.     InTeGer*4 ITCNTV(6)
  194.     COMMON/ITERA/ITCNTV
  195.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  196.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  197.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  198.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  199.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  200. C ***<<< NULETC COMMON START >>>***
  201.     InTeGer*4 ICREF,IRREF
  202. C    COMMON/MIRROR/ICREF,IRREF
  203.     InTeGer*4 MODPUB,LIMODE
  204. C    COMMON/MODPUB/MODPUB,LIMODE
  205.     InTeGer*4 KLKC,KLKR
  206.     REAL*8 AACP,AACQ
  207. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  208.     InTeGer*4 NCEL,NXINI
  209. C    COMMON/NCEL/NCEL,NXINI
  210.     CHARACTER*1 NAMARY(20,MROWS)
  211. C    COMMON/NMNMNM/NAMARY
  212.     InTeGer*4 NULAST,LFVD
  213. C    COMMON/NULXXX/NULAST,LFVD
  214.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  215.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  216. C ***<<< NULETC COMMON END >>>***
  217.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  218.     InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
  219.     COMMON/STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  220.      1  ST1LIM,ST2LIM
  221.     InTeGer*4 IATYP(27),LINTGR
  222.     CHARACTER*1 ITYP(Imp1s)
  223.     COMMON/TYP/IATYP,ITYP,LINTGR
  224.     InTeGer*4 MPAG(2),MPMOD(2)
  225.     InTeGer*2 LVALBF(5,800)
  226.     COMMON/VB/MPAG,LVALBF,MPMOD
  227.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  228.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  229.     InTeGer*4 LEVEL,NONBLK,LEND,VIEWSW,BASED
  230.     CHARACTER*1 LINE(80)
  231.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  232. C *** END COMMONS FROM OTHER PLACES.
  233.     Character*1 IYN
  234.     FH=0
  235.     NCEL=0
  236. c    IFCW=4927
  237. C DISABLE FLOATING EXCEPTIONS
  238. c    CALL LCWRQQ(IFCW)
  239. C INITIAL DEFAULT FORMAT FOR NUMERICS is set at runtime
  240. C INIT COMMON DATA FIRST OF ALL.
  241.     IDOL7=1
  242. C INITIALLY IN ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
  243. C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
  244.     CALL BLOCK
  245.     IKONS=0
  246.     write(*,6402)
  247. 6402    Format(' Compiled by Absoft Fortran 2.3.')
  248.         IYN=27
  249.         Write(*,6398)iyn,iyn
  250. 6398    Format(A,'[H',A,'[J')
  251.     Write(*,6403)
  252. 6403    Format(' Is Workbench screen 640 by 400 or over [Y/N]:')
  253.     IDSPTP=0
  254.     Read(*,6406)IYN
  255. 6406    Format(1A1)
  256.     If(IYN.eq.'Y'.or.IYN.eq.'y')IDSPTP=1
  257. c IDSPTP now is 0 for non interlace, 1 for interlace.
  258.     CALL INITA1(KMAP,KWID,ICODE)
  259. 3002    CONTINUE
  260.     CALL INITA2(KMAP,KWID,ICODE,IKONS)
  261.     IKONS=1
  262. 3000    CONTINUE
  263.     CALL INITB(KMAP,KWID,ICODE)
  264.     LINIZZ=0
  265. C    IF(IOLDFL.GT.1)GOTO 2000
  266. 2000    CONTINUE
  267. C DRAW OUR LABELS AND OTHERWISE INITIALIZE DISPLAY SHEET
  268.     KZPPD=0
  269.     IF(IPSET.NE.0)GOTO 1000
  270.     IF(PZAP.EQ.0)CALL UVT100(11,2,0)
  271.     CALL UVT100(1,1,1)
  272.     OSWIT=20
  273.     IPRSS=PROW
  274.     IPCSS=PCOL
  275.     IDRW=DROW
  276.     IDCL=DCOL
  277.     IF(LINIZZ.LE.1)CALL RECALC
  278.     IF(PZAP.EQ.0)CALL DSPSHT(2)
  279.     DCOL=IDCL
  280.     DROW=IDRW
  281.     PROW=IPRSS
  282.     PCOL=IPCSS
  283. 3006    FORMAT(80A1)
  284. C
  285. 1000    CONTINUE
  286.     IPSET=0
  287.     LINIZZ=LINIZZ+1
  288.     OSWIT=20
  289. C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
  290.     ICODE=0
  291.     CALL XQTCMD(ICODE)
  292.     IF(ICODE.LT.30)GOTO 1843
  293. C HELP COMMAND AND SIMILAR...
  294.     IF(ICODE.NE.400)GOTO 1847
  295.     CALL DSPSHT(10)
  296.     ICODE=1
  297. C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
  298.     GOTO 1843
  299. 1847    CONTINUE
  300.     IF(ICODE.NE.420)GOTO 1849
  301. C CLOSE UNIT 1 JUST IN CASE...
  302.     CLOSE(1)
  303.     KLVL=1
  304.     IPRSSS=PROW
  305.     IPCSSS=PCOL
  306.     CALL CALC
  307.     PROW=IPRSSS
  308.     PCOL=IPCSSS
  309. C CLOSE CONSOLE LUN USED BY CALC.
  310.     CLOSE(1)
  311. C CLOSE ANY OTHER LUNS CALC MAY HAVE USED...
  312.     CLOSE(2)
  313.     CLOSE(3)
  314. C SET UP FOR REDRAW WHEN BACK...
  315.     ICODE=-1
  316.     GOTO 1843
  317. 1849    CONTINUE
  318.     IF(ICODE.NE.430)GOTO 1845
  319. C TEST FUNCTION, TESTING EXPRESSION.
  320. C INHIBIT RECALCULATION...
  321. C COMMAND IS IN "XTNCMD" STRING.
  322.     LLST=MIN0(80,XTNCNT+1)
  323.     LFST=1
  324.     CALL DOENTR(XTNCMD,LFST,LLST)
  325. C THIS SETS % VARIABLE AND WILL DO A CALC DIRECTLY. THEREFORE
  326. C WE MUST INHIBIT AUTO RECALCULATION.
  327. C NOTE WE HAVE TO CALL THIS FROM THE ROOT SINCE THE RECALC OVERLAY
  328. C TREE OVERWRITES THE XQTCMD ONE.
  329.     ICODE=1
  330.     GOTO 1843
  331. 1845    CONTINUE
  332.     IVVV=ICODE-30
  333. 9308    CALL HELP(IVVV)
  334.     IVVV=0
  335.     CALL VWRT('Type return to continue, Hn for other Help pages:',
  336.      1  49)
  337.     ILL=IOLVL
  338. C    IF(ILL.EQ.5)ILL=0
  339.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)(FORM2(K),K=1,4)
  340.     if(ill.eq.11)call vget(form2,4)
  341.     IVVVV=ichar(FORM2(2))
  342.     IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
  343.     IF(FORM2(1).EQ.'H'.OR.FORM2(1).EQ.'h')GOTO 9308
  344. C NOW CLEAR SCREEN AND TRY MORE COMMANDS AS BEFORE...
  345.     ICODE=6
  346. C
  347. 1843    CONTINUE
  348.     OSWIT=20
  349.     IPRSS=PROW
  350.     IPCSS=PCOL
  351.     IDRW=DROW
  352.     IDCL=DCOL
  353.     IF(LINIZZ.LE.1)CALL RECALC
  354.     IF(IPSET.NE.0)GOTO 4110
  355.     DCOL=IDCL
  356.     DROW=IDRW
  357.     PROW=IPRSS
  358.     PCOL=IPCSS
  359. 4110    CONTINUE
  360.     IPSET=0
  361.     IF(ICODE.EQ.-1)GOTO 2000
  362. C IN PORTACALC-VM, S COMMAND ALLOWS DEFAULT FORMAT CHANGE AND
  363. C TITLE CHANGE, BUT DOES NOT ALTER SHEET IN MEMORY... DON'T ALLOW
  364. C SCRATCH FILE SAVE STUFF...
  365. C    IF(ICODE.EQ.-2)CALL WRKFIL(1,FORM,3)
  366. C    IF (ICODE.EQ.-2)CALL CLOSE(7)
  367.     IF(ICODE.LE.-2)GOTO 3002
  368. C
  369. C RECALCULATE SHEET NOW AUTOMAGICALLY
  370. C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
  371. C THE ENTIRE SHEET.
  372. C LIMIT NUMBER OF ITERATIONS AT ANY ONE TIME TO 20 HOWEVER
  373.     KKMAX=20
  374. 3670    CONTINUE
  375.     IF(ICODE.EQ.5.OR.ICODE.EQ.1
  376.      1  .OR.ICODE.EQ.6.OR.RCFGX.EQ.1)GOTO 3671
  377.     CALL RECALC
  378.     IPSET=0
  379.     KKMAX=KKMAX-1
  380. C IMPLEMENT VARY LOOP...
  381. C ASSUME USRFCT MUSTR CONTOL KALKIT VARIABLE THEN TO GET LOOP TO
  382. C TERMINATE SOMETIME.
  383.     KKMAX=MIN0(KKMAX,KALKIT)
  384.     IF(KKMAX.GT.0)GOTO 3670
  385. 3671    CONTINUE
  386. C    IF(ICODE.NE.1.AND.RCFGX.NE.1)CALL RECALC
  387. C
  388. C DISPLAY SHEET NOW. ONLY ALTERS ENTRIES INVALIDATED BY COMMAND.
  389.     IF(ICODE.NE.2.AND.ICODE.NE.6)GOTO 21
  390. C ICODE=2 = REFRESH DISPLAY. ZERO ALL NUMBERS AND CAUSE TOTAL REDISPLAY.
  391.     DO 22 N1=1,20
  392.     DO 22 N2=1,75
  393. C SET NUMBER DISPLAYED TO WEIRD VALUE.
  394. 22    DVS(N1,N2)=DVS(N1,N2)+.000000000034
  395.     IF(PZAP.EQ.0)CALL UVT100(11,2,0)
  396.     CALL UVT100(1,1,1)
  397. 21    CONTINUE
  398.     IF(ICODE.EQ.6)ICODE=2
  399.     IF(ICODE.NE.5.AND.PZAP.EQ.0)CALL DSPSHT(ICODE)
  400.     DCOL=IDCL
  401.     DROW=IDRW
  402.     PROW=IPRSS
  403.     PCOL=IPCSS
  404.     GOTO 1000
  405. 5600    CONTINUE
  406. C ERROR ON READ FROM IOLVL HANDLED HERE.
  407. c    REWIND 5
  408. c    CLOSE(11)
  409. c    OPEN(11,FILE='CON:50/150/300/40/Analy Command',STATUS='OLD',
  410. c     1  FORM='FORMATTED')
  411.     CLOSE(3)
  412.     IOLVL=11
  413.     GOTO 1000
  414.     END
  415. c -h- assign.for    Fri Aug 22 12:56:01 1986    
  416.     SUBROUTINE ASSIGN(IUNIT,NAME)
  417. C
  418. C
  419.     CHARACTER*1 NAME(50)
  420.     InTeGer*4 IUNIT
  421. C &&&& MS FTN 3.2
  422.     LOGICAL LEXIST
  423. C &&&&
  424.     CHARACTER*20 WK
  425.     CHARACTER*1 WK1(20)
  426.     EQUIVALENCE(WK(1:1),WK1(1))
  427. C JUST TRY AND NULL FILL A NAME TO USE.
  428.     DO 1 N=1,20
  429.     WK1(N)=' '
  430. 1    CONTINUE
  431.     DO 2 N=1,20
  432.     II=ICHAR(NAME(N))
  433.     IF(II.LT.32)GOTO 3
  434.     WK1(N)=CHAR(II)
  435. C1    CONTINUE
  436. 2    CONTINUE
  437. 3    CONTINUE
  438. C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
  439. C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
  440. C AVOID CRASHES IF THE FILE ISN'T THERE...
  441. C MSDOS FORTRAN 3.2 AND LATER FEATURE...
  442. C &&&&
  443. C
  444. C    INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
  445. C
  446.     INQUIRE(FILE=WK,EXIST=LEXIST)
  447.     IF(LEXIST)GOTO 100
  448. C FILE DOES NOT EXIST, SO CREATE IT HERE.
  449. C IF CREATE FAILS WE LOSE TOO...
  450.     CALL UVT100(1,1,1)
  451.     CALL SWRT('File not found. Using window instead.',37)
  452.     Open(IUNIT,'CON:200/100/300/80/Nonexistent file')
  453. C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
  454. C WILL GET EOF ON START, BUT THAT'S TOO BAD...
  455.     Return
  456. 100    CONTINUE
  457. C &&&&
  458. C IF JUST CALL ASSIGN, ASSUME FOR READ.
  459.     OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
  460.      1  FORM='FORMATTED')
  461. 77    CONTINUE
  462. C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
  463. C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
  464.     RETURN
  465.     END
  466. c -h- at.for    Fri Aug 22 12:56:23 1986    
  467.     SUBROUTINE AT (RETCD)
  468. C COPYRIGHT (C) 1983 GLENN EVERHART
  469. C ALL RIGHTS RESERVED
  470. C 60=MAX REAL ROWS
  471. C 301=MAX REAL COLS
  472. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  473. C VBLS AND TYPE DIMENSIONED 60,301
  474. C *******************************************************
  475. C *                                                     *
  476. C *           SUBROUTINE  AT                            *
  477. C *                                                     *
  478. C *******************************************************
  479. C SUBROUTINE AT IS CALLED WHEN THE  *@  CALC COMMAND IS ENCOUNTERED.
  480. C IT CHANGES  THE  VALUE  OF LEVEL  WHICH  HOLDS THE  NUMBER OF THE
  481. C LOGICAL  I/O  UNIT WHERE INPUT COMMAND LINES ARE TO BE OBTAINED.
  482. C THE FILE ASSOCIATED WITH THAT I/O UNIT IS OPENED UNDER THE PROPER
  483. C CONDITIONS.
  484. C
  485. C MODIFICATION CLASSES: M1,M2,M9
  486. C
  487. C      MODIFIED 3-OCT-77 P.B.
  488. C      MODIFIED 10-JAN-78 P.B.  TO PUT SY: BEFORE FILENAMES
  489. C         WITH NO DEVICE SPECIFIED SO THAT DEFAULT IS USER'S SY:
  490. C         AND NOT THE SYSTEM SY:
  491. C
  492. C
  493. C    AT CALLS
  494. C
  495. C  ASSIGN  (TO ASSOCIATE A FILE NAME WITH A LOGICAL I/O UNIT)
  496. C  ERRMSG  (TO PRINT ERROR MESSAGES)
  497. C  GETNNB  (TO GET NEXT NON-BLANK FROM THE INPUT LINE)
  498. C  ZNEG    (TO TEST IF A VARIABLE IS POSITIVE)
  499. C
  500. C
  501. C
  502. C   AT IS CALLED BY ROUTINE CMND WHICH IS THE MODULE THAT DETERMINES
  503. C   WHAT CALC COMMAND WAS REQUESTED.
  504. C
  505. C
  506. C
  507. C         VARIABLE          USE
  508. C
  509. C   ALPHA(27)         HOLDS LEGAL VARIABLE NAMES.
  510. C   I,J               HOLD TEMPORARY VALUES.
  511. C   IPT               POINTS TO NEXT NON-BLANK CHARACTER IN LINE(80).
  512. C   ITCNTV(6)         INDEXED BY LEVEL. HOLDS 0 IF NO ITERATION ON THAT
  513. C                     LEVEL, OTHERWISE INDEX INTO VBLS FOR THE VARIABLE
  514. C                     THAT CONTROLS ITERATION.
  515. C   LEVEL             HOLDS NUMBER OF LOGICAL I/O UNIT WHERE NEXT INPUT
  516. C                     LINE IS EXPECTED.
  517. C   LINE(80)          HOLDS COMMAND INPUT LINE.
  518. C   NBLINE(78)        HOLDS THE INPUT FILE NAME WITHOUT BLANKS.
  519. C   NONBLK            POINTS TO THE LAST NON-BLANK CHARACTER IN LINE(80).
  520. C   RETCD             RETURN CODE: 1=O.K.  2=ERROR.
  521. C   SY                "SY:" USED TO OPEN FILES WITH A DEFAULT OF
  522. C                     USER'S SY: (OTHERWISE SYSTEM SY: IS USED) P.B.
  523. C                     10-JAN-78
  524. C
  525. C
  526. C
  527. C    SUBROUTINE AT (RETCD)
  528. C
  529.     InTeGer*4 IPT,J,I
  530.     InTeGer*4 LEVEL,NONBLK,LEND
  531.     InTeGer*4 RETCD,VIEWSW,BASED
  532.     InTeGer*4 ITCNTV(6),ZNEG
  533. C
  534.     CHARACTER*1  LINE(80),NBLINE(78)
  535.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  536. C    CHARACTER*1 SY(3)
  537. C
  538. C
  539.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  540.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  541.     COMMON/ITERA/ITCNTV
  542. C
  543. C    DATA SY/'S','Y',':'/
  544. C
  545. C
  546. C
  547. C UPON ENTRANCE, NONBLK POINTS TO THE CHARACTER @
  548. C
  549. C  MODIFICATION CLASSES:  M1,M2,M9
  550. C
  551. C PICK UP FIRST NON-BLANK AFTER THE @
  552.     CALL GETNNB(IPT,RETCD)
  553.     GO TO (10,1050),RETCD
  554.     STOP 10
  555. C
  556. C
  557. C START BUILDING FILE NAME AS A COMPRESSED VERSION (BLANKS REMOVED)
  558. C OF THE REST OF LINE(80)
  559. 10    J=0
  560. 15    NONBLK=IPT
  561.     J=J+1
  562.     NBLINE(J)=LINE(NONBLK)
  563.     CALL GETNNB(IPT,RETCD)
  564.     GO TO (15,50),RETCD
  565.     STOP 50
  566. C
  567. C
  568. C SET RETURN CODE AND INDICATE THAT WE WILL BE AT A NEW LEVEL.
  569. C J HOLDS THE COUNT OF THE NUMBER OF CHARACTERS IN NBLINE.
  570. C IF J=1 THEN NO ITERATION IS POSSIBLE BECAUSE FILENAME IS THE
  571. C SINGLE CHARACTER.
  572. 50    RETCD=1
  573.     LEVEL=LEVEL+1
  574.     IF (LEVEL.GT.6) GOTO 1000
  575. C
  576.     IF(J.EQ.1) GO TO 200
  577. C
  578. C NBLINE HOLDS THE COMPRESSED FILENAME. NOW WE CHECK TO SEE IF AN
  579. C ITERATION VARIABLE WAS SPECIFIED. THIS IS INDICATED BY A LEGAL
  580. C VARIABLE NAME PRECEEDED BY A BLANK (IN LINE(80))
  581. C NOTE THAT ONLY ONE OF THE ACCUMULATORS A-Z MAY BE USED FOR THIS.
  582.     DO 60 I=1,27
  583. C A-Z OR % LEGAL
  584.     IF(ALPHA(I).EQ.LINE(NONBLK))GO TO 100
  585. 60    CONTINUE
  586.     GO TO 200
  587. 100    IF(LINE(NONBLK-1).NE.BLANK)GO TO 200
  588. C
  589. C
  590. C ITERATION INDICATOR IS PRESENT
  591. C (ALPHABETIC CHARACTER OR % PRECEEDED BY A BLANK)
  592. C IF THE VALUE OF THE VARIABLE IS NOT POSITIVE, THE FILE IS IGNORED.
  593.     IF(ZNEG(I).EQ.1)GO TO 150
  594. C
  595. C
  596. C RETAIN INDEX INTO VBLS AND DECREASE J SO THAT THE FILENAME
  597. C DOES NOT INCLUDE THE ITERATION SPECIFICATION.
  598.     ITCNTV(LEVEL)=I
  599.     J=J-1
  600.     GO TO 300
  601. C
  602. C
  603. C FILE NOT ENTERED, ITERATION VARIABLE IS ZERO, NEGATIVE, OR UNDEFINED
  604. 150    LEVEL=LEVEL-1
  605.     GO TO 350
  606. C
  607. C
  608. C IF NO ITERATION, SET ITCNTV TO ZERO BECAUSE NOT ZEROED BY EXIT
  609. C ROUTINES
  610. 200    ITCNTV(LEVEL)=0
  611. 300    CONTINUE
  612.     NBLINE(J+1)=0
  613. C    OPEN(UNIT=LEVEL,NAME=NBLINE)
  614. C    CALL RASSIG (LEVEL,NBLINE,J)
  615.     CALL RASSIG (LEVEL,NBLINE)
  616. 350    RETURN
  617. C
  618. C *** ERROR PROCESSING ***
  619. C
  620. C  TOO MANY LEVELS
  621. 1000    I=2
  622. 1010    CALL ERRMSG(I)
  623. 1020    RETCD=2
  624.     RETURN
  625. C
  626. C
  627. C UNIDENTIFIED COMMAND (ARGUMENT)
  628. 1050    I=3
  629.     GO TO 1010
  630.     END
  631. c -h- bascng.for    Fri Aug 22 12:57:23 1986    
  632.     SUBROUTINE BASCNG(RETCD)
  633. C COPYRIGHT (C) 1983 GLENN EVERHART
  634. C ALL RIGHTS RESERVED
  635. C 60=MAX REAL ROWS
  636. C 301=MAX REAL COLS
  637. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  638. C VBLS AND TYPE DIMENSIONED 60,301
  639. C
  640. C SUBROUTINE BASCNG IS CALLED WHEN THE *B CALC COMMAND IS
  641. C ENCOUNTERED. THIS COMMAND INDICATES THAT THE DEFAULT BASE
  642. C FOR CONSTANTS IS TO BE CHANGED. THE ROUTINE READS IN ONE
  643. C OR TWO DIGITS AND CHANGES THE DEFAULT BASE SPECIFICATION
  644. C AS IS APPROPRIATE.
  645. C
  646. C MODIFICATION CLASS M2
  647. C
  648. C   BASCNG CALLS
  649. C
  650. C  ERRMSG  (PRINTS ERROR MESSAGES)
  651. C  GETNNB  (GETS THE NEXT NON-BLANK IN INPUT LINE LINE(80))
  652. C
  653. C
  654. C  BASCNG IS CALLED BY ROUTINE CMND WHICH IDENTIFIES THE COMMAND THAT
  655. C  THE USER WANTS TO EXECUTE.
  656. C
  657. C
  658. C    VARIABLE       USE
  659. C
  660. C    BASED       HOLDS THE DEFAULT BASE.
  661. C    IPT         POINTS TO THE NEXT NON-BLANK IN LINE(80).
  662. C    I1          BINARY VALUE OF FIRST DIGIT, VALUE OF NEW BASE.
  663. C    I2          BINARY VALUE OF SECOND DIGIT.
  664. C    NONBLK      POINTS TO THE LAST NON-BLANK IN LINE(80)
  665. C    RETCD       RETURN CODE: 1=O.K.  2=ERROR.
  666. C    RETCD2      HOLDS RETURN CODE FROM CALL TO GETNNB
  667. C
  668. C
  669. C
  670. C
  671. C    SUBROUTINE BASCNG(RETCD)
  672. C
  673. C
  674. C UPON ENTRANCE, NONBLK POINTS TO THE 'B' IN '*B' IN LINE
  675. C
  676.     InTeGer*4 IPT,I1,I2
  677.     InTeGer*4 LEVEL,NONBLK,LEND
  678.     InTeGer*4 RETCD,RETCD2,VIEWSW,BASED
  679. C
  680.     CHARACTER*1 DIGITS(16,3),LINE(80)
  681. C
  682.     COMMON /DIGV/ DIGITS
  683.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  684. C
  685. C
  686. C IF NO ARGUMENT, RETURN WITH NORMAL RETURN CODE. THIS ALLOWS THE
  687. C USER TO SEE WHAT THE PRESENT DEFAULT BASE IS.
  688.     RETCD=1
  689.     CALL GETNNB(IPT,RETCD2)
  690.     IF(RETCD2.GT.1)GO TO 1000
  691. C
  692. C
  693. C CHECK OUT FIRST DIGIT
  694.     DO 300 I1=1,10
  695.     IF(DIGITS(I1,1).EQ.LINE(IPT)) GO TO 400
  696. 300    CONTINUE
  697.     GO TO 999
  698. C
  699. C
  700. C SEE IF THERE IS A SECOND DIGIT
  701. 400    NONBLK=IPT
  702.     IF(I1.EQ.10)I1=0
  703.     CALL GETNNB(IPT,RETCD2)
  704.     IF(RETCD2.EQ.1)GO TO 500
  705. C
  706. C
  707. C IF NOT, CONVERT TO A TWO DIGIT NUMBER WITH A LEADING ZERO.
  708.     I2=I1
  709.     I1=0
  710.     GO TO 700
  711. C
  712. C A SECOND CHARACTER WAS FOUND; FIGURE OUT WHAT THE BINARY
  713. C VALUE IS (IF IT IS A DIGIT AT ALL).
  714. 500    DO 600 I2=1,10
  715.     IF(DIGITS(I2,1).EQ.LINE(IPT))GO TO 700
  716. 600    CONTINUE
  717.     GO TO 999
  718. C
  719. C CONVERT DIGITS TO A NUMBER IF IT IS LEGAL
  720. 700    IF(I2.EQ.10)I2=0
  721.     I1=I1*10+I2
  722.     IF(I1.NE.8.AND.I1.NE.10.AND.I1.NE.16) GO TO 999
  723.     BASED=I1
  724.     GO TO 1000
  725. C
  726. C
  727. C ILLEGAL BASE SPECIFICATION
  728. 999    RETCD=2
  729.     call vwrt(' Illegal Base. (Only 8,10, and 16 OK). Ignored.',
  730.      1  48)
  731. c    WRITE(11,998)
  732. c998    FORMAT(' Illegal Base. (Only 8,10,and 16 OK). Ignored.')
  733. C    CALL ERRMSG(19)
  734. C
  735. C RETURN
  736. 1000    RETURN
  737.     END
  738. c -h- blkdat.for    Fri Aug 22 12:57:49 1986    
  739.     BLOCK DATA
  740. C COPYRIGHT 1983 GLENN C.EVERHART
  741. C ALL RIGHTS RESERVED
  742.     Include AParms.inc
  743. C    InTeGer*4 MFID(2),MFMOD(2)
  744.     InTeGer*2 IFID(8,MFrm)
  745.     COMMON/IFIDC/IFID
  746.     CHARACTER*1 LFID(16,MFrm)
  747.     EQUIVALENCE(IFID(1,1),LFID(1,1))
  748. C    COMMON/FRM/MFID,MFMOD
  749.     CHARACTER*1 DTBL1(9,9,8)
  750. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  751.     InTeGer*2 BTBL(6,6,8)
  752. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  753. C NO NEED TO WASTE IT.
  754. c    INTEGER DTBLIN
  755. C DTBLIN FLAGS THAT DTBL1 WAS ALREADY INITED, SO ONLY DOES SO ONCE.
  756.     EQUIVALENCE(LFID(1,1),BTBL(1,1,1))
  757.     InTeGer*2 BTBL1(6,6)
  758.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  759.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  760.     EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  761.     EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  762.     EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  763.     EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  764.     COMMON /DECIDE/ DTBL1
  765. cc    DATA DTBLIN/0/
  766.     DATA BTBL1 /4,2,3,4,8,9,
  767.      1  6*0,0,2,0,0,0,9,0,2,0,0,0,9,
  768.      2  0,2,3,0,0,9,0,2,4*0/
  769.     DATA BTBL2/
  770.      3  4,5*0,2,0,3*2,0,3,3*0,2*0,4,3*0,2*0,
  771.      4  8,5*0,9,0,3*9,0/
  772.     DATA BTBL3/4,2,3,4,8,9,
  773.      5  6*2,3,2,3,3,3,9,4,2,3,4,4,9,
  774.      6  8,2,3,4,8,9,9,2,4*9/
  775.     DATA BTBL4/
  776.      7  4,2,3,4,8,9,6*2,3,2,3,3,3,9,4,2,3,4,4,9,
  777.      8  8,2,3,4,8,9,
  778.      9  9,2,4*9/
  779.     DATA BTBL5/4,2,3,3*4,6*0,6*0,6*0,
  780.      1  6*0,6*0/
  781.     DATA BTBL6/4,3*0,4,0,4,3*0,0,0,4,3*0,2*0,4,3*0,2*0,
  782.      2  4,3*0,2*0,
  783.      3  4,3*0,2*0/
  784.         DATA BTBL7/4,2,3,3*4,6*2,6*3,6*4,
  785.      4  6*8,6*9/
  786.     DATA BTBL8/4,1,4,4,4,3,2,1,2,2,2,1,4,3,4,4,
  787.      5  4,3,4,3,4,4,4,3,4,3,4,4,
  788.      6  4,3,2,1,2,2,2,1/
  789.     END
  790. c -h- ca2e.for    Fri Aug 22 13:00:17 1986    
  791.     SUBROUTINE CA2E(LNIN,LNOUT)
  792. C CONVERT NORMAL ASCII FORM TO ENCODED
  793.     INCLUDE APARMS.INC
  794.     CHARACTER*1 NAME(4),NUMBER(6)
  795.     CHARACTER*1 LNIN,LNOUT
  796.     CHARACTER*6 NUMBR6
  797.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  798.     DIMENSION LNIN(128),LNOUT(128)
  799.     InTeGer*4 RRWACT,RCLACT
  800. C    COMMON/RCLACT/RRWACT,RCLACT
  801.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  802.      1  IDOL7,IDOL8
  803. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  804. C     1  IDOL7,IDOL8
  805.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  806. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  807.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  808. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  809. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  810. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  811.     InTeGer*4 KLVL
  812. C    COMMON/KLVL/KLVL
  813.     InTeGer*4 IOLVL,IGOLD
  814. C    COMMON/IOLVL/IOLVL
  815. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  816. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  817.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  818.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  819.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  820.      3  k3dfg,kcdelt,krdelt,kpag
  821. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  822. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  823. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  824. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  825. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  826. C    LOGICAL*2 L63,L192,L255,L128
  827.     LOGICAL*4 L1,L2
  828. C    InTeGer*4 I63,I192,I255,I128
  829.     InTeGer*4 I63,I192,I127
  830.     InTeGer*4 I1,I2
  831. C    EQUIVALENCE(L128,I128)
  832. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  833.     EQUIVALENCE (I1,L1),(I2,L2)
  834. C    DATA I63/63/,I192/192/,I255/255/,I128/128/
  835.     DATA I63/63/,I192/192/,I127/127/
  836.     LI=1
  837.     LO=1
  838. C LI = INPUT LOCATION
  839. C LO=OUTPUT LOCATION
  840. 100    CONTINUE
  841.     LCC=ICHAR(LNIN(LI))
  842.     IF(LCC.EQ.255)GOTO 500
  843. C IF BINARY FORM, COPY 3 BYTES TO AVOID ERRORS.
  844. D    If(K3dfg.gt.0)goto 200
  845.     IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
  846. C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
  847.     IL1=LI
  848.     LE=110
  849.     LSTC=LE
  850.     CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
  851. C AVOID MESSING UP FUNCTION NAMES
  852.     IF(ID2.EQ.1)IVLD=0
  853.     IF(IDOL1.NE.0.OR.IDOL2.NE.0)IVLD=0
  854. C ONLY REPACK NORMAL FORM NAMES
  855. C NOTE THAT SINCE THESE HAVE $ AFTER THE FIELDS, NO PARTIAL NAME
  856. C WILL EVER GET RECOGNIZED WITHOUT IDOL1 OR IDOL2 GETTING SET.
  857.     IF(IVLD.EQ.0)GOTO 200
  858. C ALIASED NAMES MIGHT GET SCANNED WITHIN PRIME AREA IF THE FIRST
  859. C ONE OR TWO CHARS GET STRIPPED OFF, SO TREAT LIKE P## OR D## FORMS
  860. C AND COPY THE WHOLE NAME HERE.
  861. C NOTE: WE LEAVE THE LIMITS HERE AT 60 AND 301 EVEN IF THE
  862. C SHEET DIMENSIONS CHANGE. THE ENCODING SCHEME BREAKS
  863. C DOWN OVER 63 BY 255 ANYWAY, SO JUST LEAVE LARGER NAMES
  864. C ALONE.
  865.     If(Kpag.gt.0)goto 250
  866.     If(K3DFG.GT.0)GOTO 250
  867. C Don't encode variables if using 3D addressing since this
  868. C could force the 3D addressing information to be lost.
  869.     IF(ID1.GT.60.OR.ID2.GT.301)GOTO 250
  870. C ALSO DON'T PACK ALIASED NAMES; THEY WON'T FIT IN CODED VALUES.
  871. C FOUND VARIABLE.
  872. C FIRST DON'T PACK P## AND D## FORMS.
  873.     IF(LNIN(LI+1).EQ.'#')GOTO 250
  874. C REPACK NORMAL VARIABLE HERE.
  875.     LI=LSTC
  876.     LNOUT(LO)=CHAR(255)
  877.     I1=IMASK(ID1,I63)
  878. C    I1=ID1
  879. C    L1=L1.AND.L63
  880.     I2=ID2/2
  881.     I2=IMASK(I2,I192)
  882. C    L2=L2.AND.L192
  883. C    L1=L1.OR.L2
  884.     I1=I1+I2
  885.     LNOUT(LO+1)=CHAR(I1)
  886. C    I2=ID2
  887.     I2=IMASK(ID2,I127)+128
  888. C    L2=L2.AND.L255
  889. C    L2=L2.OR.L128
  890.     LNOUT(LO+2)=CHAR(I2)
  891.     LO=MIN0(109,LO+3)    
  892.     GOTO 300
  893. 250    CONTINUE
  894. C JUST COPY DISPLAY FORMS.
  895.     IL1=LSTC-1
  896.     DO 251 N=LI,IL1
  897.     LNOUT(LO)=LNIN(N)
  898.     LO=LO+1
  899.     IF(LO.GT.110)GOTO 300
  900. 251    CONTINUE
  901.     LI=LSTC
  902. C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
  903.     GOTO 300
  904. 200    CONTINUE
  905. C HERE CHECK FOR FORMULA...
  906. C NOTE THAT SOME NAMES (E.G. "AVG" COULD CONFLICT WITH VERY LARGE COLUMN
  907. C NAMES. HOWEVER, IGNORE THAT POSSIBILITY. THAT'S AWFULLY FAR OUT.
  908.     CALL FNAME(LNIN(LI),II,INDX)
  909.     IF(INDX.LE.0.OR.INDX.GT.25)GOTO 220
  910. C Ensure that functions with indices too large to encode are
  911. C just treated literally. 229+25=254, the largest index we can have
  912. C before colliding with the 255 used to encode variable names.
  913. C thus all function names past the 25th must just be literally
  914. C entered. This is not really a problem as logic to find them
  915. C will work in either encoded or unencoded cases.
  916. C BE SURE A [ CHAR FOLLOWS NAME FOR THIS TO BE ACCEPTED...
  917.     IF(LNIN(LI+3).NE.'[')GOTO 220
  918. C FOUND MULTI-INPUT FUNCT NAME
  919.     LNOUT(LO)=CHAR(229+INDX)
  920. C SIMPLE 1-BYTE ENCODE OF NEEDED FUNCT NAME. NOT IN ANY CRITICAL RANGES...
  921.     LO=LO+1
  922.     LI=LI+3
  923.     GOTO 300
  924. 220    CONTINUE
  925.     LNOUT(LO)=LNIN(LI)
  926. C JUST COPY MISC. CHARACTER.
  927.     LO=LO+1
  928.     LI=LI+1
  929. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  930. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  931.     LO=MIN0(LO,110)
  932.     DO 400 N=LO,110
  933. 400    LNOUT(N)=0
  934. C COPY REST OF 128 BYTE ARRAY
  935.     DO 1 N=111,128
  936. 1    LNOUT(N)=LNIN(N)
  937. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  938.     RETURN
  939. 500    CONTINUE
  940. C SPECIAL COPY OF 3 BYTE PACKED FORMS FOR SPEED
  941.     LNOUT(LO)=LNIN(LI)
  942.     LNOUT(LO+1)=LNIN(LI+1)
  943.     LNOUT(LO+2)=LNIN(LI+2)
  944.     LO=LO+3
  945.     LI=LI+3
  946.     GOTO 300
  947.     END
  948. c -h- calbin.for    Fri Aug 22 13:00:17 1986    
  949.     SUBROUTINE CALBIN(RETCD)
  950. C COPYRIGHT (C) 1983,1984 GLENN EVERHART
  951. C ALL RIGHTS RESERVED
  952. C 60=MAX REAL ROWS
  953. C 301=MAX REAL COLS
  954. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  955. C VBLS AND TYPE DIMENSIONED 60,301
  956. C
  957. C *******************************************************
  958. C *                                                     *
  959. C *             SUBROUTINE  CALBIN                      *
  960. C *                                                     *
  961. C *******************************************************
  962. C
  963. C  SUBROUTINE CALBIN PERFORMS A BINARY OPERATION ON TWO CONSTANTS.
  964. C
  965. C special version with multiple precision diked out - gce (to save space
  966. C on 256K PC)
  967. C  UPON ENTRANCE TO ROUTINE:
  968. C    OPERAND1 IS IN STACK1  (ST1PT-1)
  969. C    OPERAND2 IS ON TOP OF STACK2  (ST2PT-1)
  970. C    OPERATOR IS BELOW OPERAND2  (ST2PT-2)
  971. C  UPON EXIT:
  972. C    RESULT IS IN STACK1
  973. C    STACK2 HAS BEEN CLEANED UP
  974. C
  975. C  RETURN CODE    MEANING
  976. C    1    NORMAL RETURN
  977. C    2    OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
  978. C    3    ERROR RETURN
  979. C
  980. C
  981. C
  982. C  MODIFICATION CLASSES: M3, M4, AND M8
  983. C
  984. C
  985. C
  986. C  CALBIN CALLS
  987. C
  988. C  CONTYP   CONVERTS CONSTANTS TO DIFFERENT DATA TYPES
  989. C  ERRMSG   PRINTS OUT ERROR MESSAGES
  990. C  MULADD   PERFORMS MULTIPLE PRECISION ADDITION
  991. C  MULDIV   PERFORMS MULTIPLE PRECISION DIVISION
  992. C  MULMUL   PERFORMS MULTIPLE PRECISION MULTIPLICATION
  993. C
  994. C
  995. C
  996. C CALBIN IS CALLED BY POSTVL WHICH EVALUATES A POSTFIX EXPRESSION
  997. C
  998. C
  999. C
  1000. C
  1001. C   VARIABLE     USE
  1002. C
  1003. C  EIGHT(8)      PICKS OUT A REAL CONSTANT FROM STACK.
  1004. C  FOUR(4)       PICKS OUT AN INTEGER CONSTANT FROM STACK.
  1005. C  I,J           HOLD TEMPORARY VALUES.
  1006. C  IA            FIRST BYTE OF OPERAND 1. THIS HOLDS THE INDEX INTO
  1007. C                VBLS OF A VARIABLE IF THE OPERATOR IS AN = SIGN.
  1008. C  ID            USED TO CONVERT DECISION TABLE CHARACTER*1 VALUE TO
  1009. C                AN InTeGer*4 VALUE THAT CAN BE USED AS AN ARGUMENT
  1010. C                IN A CALL TO CONTYP.
  1011. C  INT,IHOLD     HOLD INTEGER*4 VALUES.
  1012. C  IOP           HOLDS THE BINARY OPERATOR.
  1013. C  IOP2          USED TO INDEX A COMPUTED GO.
  1014. C  ISW           HOLDS BASE FOR MULTIPLE PRECISION EXPONENTIATION
  1015. C  MINUS         VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
  1016. C                NUMBER THAT IS USED TO INDICATE A NEGATIVE.
  1017. C  OP1TYP        TYPE OF OPERAND 1.
  1018. C  OP2TYP        TYPE OF OPERAND 2.
  1019. C  PLUS          VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
  1020. C                NUMBER THAT IS USED TO INDICATE POSITIVE.
  1021. C  PT1,PT2       POINT TO ELEMENTS ON TOP OF STACKS 1 AND 2.
  1022. C  REAL,RHOLD    HOLD TEMPORARY REAL*8 VALUES.
  1023. C  RETCD         ERROR RETURN:  1 = O.K.   2 = RESULT WAS OUTPUT
  1024. C                3 = ERROR
  1025. C
  1026. C
  1027. C    SUBROUTINE CALBIN(RETCD)
  1028.     REAL*8 REAL,RHOLD,DFLOAT
  1029. C
  1030.     INTEGER*4 INT,IHOLD
  1031. C
  1032.     InTeGer*4 LEVEL,NONBLK,LEND
  1033.     InTeGer*4 VLEN(9)
  1034.     InTeGer*4 IOP,IA,ID,IOP2,ISW
  1035.     InTeGer*4 PLUS,MINUS
  1036.     InTeGer*4 OLDTYP,VIEWSW,BASED
  1037.     InTeGer*4 TYPE(1,1)
  1038.     InTeGer*4 RETCD,RETCD2
  1039.     InTeGer*4 OP1TYP,OP2TYP
  1040.     InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
  1041.     InTeGer*4 PT1,PT2
  1042. C
  1043.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  1044.     InTeGer*4 STK12(2,40)
  1045.     REAL*8 XVBLK
  1046.     EQUIVALENCE(STK12(1,1),STACK1(1,1))
  1047.     CHARACTER*1 AVBLS(20,27), DTBL1(9,9,8)
  1048.     CHARACTER*1 VBLS(8,1,1)
  1049.     EQUIVALENCE (XVBLK,VBLS(1,1,1))
  1050.     CHARACTER*1 EIGHT(8),FOUR(4)
  1051.     CHARACTER*1 LINE(80)
  1052. C
  1053.     EQUIVALENCE (EIGHT,REAL), (FOUR,INT)
  1054. C
  1055.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  1056.     COMMON/V/ TYPE,AVBLS,VBLS,VLEN
  1057.     COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  1058.      ;         ST1LIM,ST2LIM
  1059.     COMMON /DECIDE/DTBL1
  1060. C
  1061. C
  1062.     DATA PLUS/0/,MINUS/1/
  1063. C
  1064. C
  1065.     RETCD=1
  1066.     PT1=ST1PT-1
  1067.     PT2=ST2PT-1
  1068. C
  1069.     IOP=ST2TYP(ST2PT-2)
  1070.     OP1TYP=ST1TYP(PT1)
  1071.     OP2TYP=ST2TYP(PT2)
  1072. C NOTE THAT IA IS UNUSED HERE... SAVE BIG DIMENSIONS
  1073.     IA=ICHAR(STACK1(1,PT1))
  1074.     ID1=STK12(1,PT1)
  1075.     ID2=STK12(2,PT1)
  1076. C    CALL GETDM(STACK1(1,PT1),ID1,ID2)
  1077. C ****&&&& ABOVE GETS LOCS IN 2 DIM ARRAY OF VARIABLES
  1078.     IF (IOP.NE.200) GOTO 100
  1079. C
  1080. C
  1081. C
  1082. C AN = SIGN IS THE OPERATOR. THIS IS A SPECIAL CASE.
  1083.     IF(OP1TYP.GE.0) GO TO 5
  1084. C
  1085. C
  1086. C
  1087. C VARIABLE TO THE LEFT OF = SIGN HAS A DATA TYPE BUT NO VALUE
  1088.     OP1TYP=-OP1TYP
  1089.     ST1TYP(PT1)=OP1TYP
  1090. C
  1091. C
  1092. C
  1093. C OPERAND 2 COPIED INTO OLD OPERAND'S POSITION IN CASE MORE
  1094. C THAN 1 = SIGN IS PRESENT FOR EXPRESSIONS LIKE  I=J=2
  1095. 5    J=VLEN(OP2TYP)
  1096. C    TYPE(IA)=OP1TYP
  1097.     CALL TYPSET(ID1,ID2,OP1TYP)
  1098. C    TYPE(ID1,ID2)=OP1TYP
  1099. C *&*****&&&&& NOTE TYPE ARRAY AND VBLS ARRAY NOW ARE HUGE
  1100. C  NOTE FURTHER THAT AVBLS IS OLD VBLS ARRAY. SWITCHED ON IF
  1101. C ID1 =< 27 AND ID2=1.
  1102.     DO 10 I=1,J
  1103. 10    STACK1(I,PT1)=STACK2(I,PT2)
  1104.     CALL CONTYP (STACK1,PT1,OP2TYP,OP1TYP,RETCD2)
  1105.     GOTO (20,9999), RETCD2
  1106.     STOP 20
  1107. C
  1108. C
  1109. C THE SPECIFIED VARIABLE GETS NEW VALUE.
  1110. C ***&&&& HERE'S WHERE WE STORE A VALUE INTO A VARIABLE...
  1111. 20    J=VLEN(OP1TYP)
  1112.     DO 30 I=1,J
  1113. C    VBLS(I,IA)=STACK1(I,PT1)
  1114.     IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 22
  1115. C REPLACE VBLSET CALL WITH XVBLST CALL ON LAST PASS TO AVOID
  1116. C MULTIPLE REPLACEMENT OF STORAGE FOR EVERY PASS.
  1117.     VBLS(I,1,1)=STACK1(I,PT1)
  1118.     IF(I.EQ.J)CALL XVBLST(ID1,ID2,XVBLK)
  1119. C    CALL VBLSET(I,ID1,ID2,STACK1(I,PT1))
  1120. C    VBLS(I,ID1,ID2)=STACK1(I,PT1)
  1121.     GOTO 30
  1122. 22    AVBLS(I,ID1)=STACK1(I,PT1)
  1123. C *****&&&&&
  1124. 30    CONTINUE
  1125.     GOTO 10000
  1126. C
  1127. C
  1128. C  IOP2 VALUES 1="**"  2="*"   3="/"   4="+"   5="-"
  1129. 100    IOP2=IOP-111
  1130.     GOTO (1000,2000,2000,2000,2000),IOP2
  1131. C
  1132. C
  1133. C    ********************************************
  1134. C    ***********  EXPONENTIATION  ***************
  1135. C    ********************************************
  1136. C
  1137. C
  1138. C  FIRST CONVERT TO PROPER TYPE
  1139. 1000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,5))
  1140.     CALL CONTYP(STACK1,PT1,OP1TYP,ID,RETCD2)
  1141.     IF (RETCD2.EQ.2) GOTO 9999
  1142.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,6))
  1143.     CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
  1144.     IF (RETCD2.EQ.2) GOTO 9999
  1145. C
  1146. C
  1147. C  GOTO APPROPRIATE PLACE TO PERFORM OPERATION
  1148.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,8))
  1149.     GOTO (1100,1200,1300,1400,1500,1600,1700),ID
  1150.     STOP 1000
  1151. C
  1152. C
  1153. C  REAL**REAL
  1154. 1100    DO 1104 I=1,8
  1155. 1104    EIGHT(I)=STACK1(I,PT1)
  1156.     RHOLD=REAL
  1157.     DO 1108 I=1,8
  1158. 1108    EIGHT(I)=STACK2(I,PT2)
  1159.     REAL=RHOLD**REAL
  1160. C
  1161. C
  1162. C  USED BY REAL**I
  1163. 1109    DO 1110 I=1,8
  1164. 1110    STACK1(I,PT1)=EIGHT(I)
  1165. C
  1166. C
  1167. C  USED BY I**REAL,I**I
  1168. 1114    ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,7))
  1169.     GOTO 10000
  1170. C
  1171. C
  1172. C
  1173. C  REAL**I
  1174. 1200    DO 1204 I=1,8
  1175. 1204    EIGHT(I)=STACK1(I,PT1)
  1176.     DO 1208 I=1,4
  1177. 1208    FOUR(I)=STACK2(I,PT2)
  1178.     REAL=REAL**INT
  1179.     GOTO 1109
  1180. C
  1181. C
  1182. C
  1183. C  I**REAL (PARTS USED BY I**I)
  1184. 1300    DO 1304 I=1,4
  1185. 1304    FOUR(I)=STACK1(I,PT1)
  1186.     DO 1308 I=1,8
  1187. 1308    EIGHT(I)=STACK2(I,PT2)
  1188. C
  1189. C DIFFERENT VERSIONS OF FORTRAN TREAT THE RESULT IN DIFFERENT WAYS.
  1190. C IF YOU WANT THE RESULT TO BE REAL, YOU MUST ALSO CHANGE DTBL1.
  1191. C
  1192.     INT=DFLOAT(INT)**REAL
  1193. 1310    DO 1314 I=1,4
  1194. 1314    STACK1(I,PT1)=FOUR(I)
  1195.     GOTO 1114
  1196. C
  1197. C
  1198. C
  1199. C  I**I
  1200. 1400    DO 1404 I=1,4
  1201. 1404    FOUR(I)=STACK1(I,PT1)
  1202.     IHOLD=INT
  1203.     DO 1408 I=1,4
  1204. 1408    FOUR(I)=STACK2(I,PT2)
  1205.     INT=IHOLD**INT
  1206.     GOTO 1310
  1207. C
  1208. C
  1209. C
  1210. C  M8**I    (PARTS USED BY M10**I, M16**I)
  1211. 1500    ISW=8
  1212. 1501    IF(ST2PT.LE.ST2LIM)GO TO 1502
  1213. C
  1214. C
  1215. C STACK OVERFLOW
  1216.     CALL ERRMSG(9)
  1217.     GO TO 9999
  1218. C
  1219. C
  1220. C GET EXPONENT AS AN INTEGER
  1221. 1502    DO 1504 I=1,4
  1222. 1504    FOUR(I)=STACK2(I,PT2)
  1223.     IF (INT.GE.0) GOTO 1520
  1224. C
  1225. C
  1226. C EXPONENT NOT POSITIVE OR 0
  1227.     CALL ERRMSG (15)
  1228.     GOTO 9999
  1229. 1520    IF (INT.GT.0) GOTO 1530
  1230. C
  1231. C
  1232. C I**0 = 1
  1233.     STACK1(8,PT1)=PLUS
  1234.     DO 1522 I=2,7
  1235. 1522    STACK1(I,PT1)=0
  1236. C LEAVE AS INTEGER SETS HERE RATHER THAN EXPLICIT CHAR() CALLS
  1237.     STACK1(1,PT1)=1
  1238.     GOTO 10000
  1239. C
  1240. C
  1241. C EXPONENT IS > 0
  1242. 1530    INT=INT-1
  1243. C
  1244. C
  1245. C IF EXPONENT = 1 WE ARE DONE
  1246.     IF(INT.EQ.0)GO TO 10000
  1247. C
  1248. C
  1249. C EXPONENT IS > 1. COPY TO STACK 2 WHERE MULMUL EXPECTS THE OTHER
  1250. C FACTOR.
  1251.     DO 1534 I=1,8
  1252. 1534    STACK2(I,ST2PT)=STACK1(I,PT1)
  1253.     ST2TYP(ST2PT)=ST1TYP(PT1)
  1254. C
  1255. C
  1256. C
  1257. C
  1258. 1549    continue
  1259. c1549    DO 1550 I=1,INT
  1260. c    CALL MULMUL(PT1,ST2PT,RETCD2,ISW)
  1261. c    IF(RETCD2.GE.2)GO TO 9999
  1262. c1550    CONTINUE
  1263.     GOTO 10000
  1264. C
  1265. C  M10**I
  1266. 1600    ISW=10
  1267.     GOTO 1501
  1268. C
  1269. C
  1270. C
  1271. C  M16**I
  1272. 1700    ISW=16
  1273.     GOTO 1501
  1274. C
  1275. C
  1276. C  *****************************************
  1277. C  * MAKE CONVERSIONS APPROPRIATE FOR */+- *
  1278. C  *****************************************
  1279. 2000    CONTINUE
  1280.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,1))
  1281.     CALL CONTYP (STACK1,PT1,OP1TYP,ID,RETCD2)
  1282.     IF (RETCD2.EQ.2) GOTO 9999
  1283.     IF(ID.EQ.0)GO TO 2010
  1284.     ST1TYP(PT1)=ID
  1285.     OP1TYP=ID
  1286. 2010    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,2))
  1287.     CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
  1288.     IF (RETCD2.EQ.2) GOTO 9999
  1289.     IF(ID.EQ.0)GOTO 2020
  1290.     ST2TYP(PT2)=ID
  1291.     OP2TYP=ID
  1292. C
  1293. 2020    CONTINUE
  1294. C
  1295. C
  1296. C  GOTO SECTION ACCORDING TO OPERATION *=3000, /=4000,+=5000,-=6000
  1297.     GOTO (2100,3000,4000,5000,6000),IOP2
  1298. 2100    STOP 2100
  1299. C
  1300. C
  1301. C
  1302. C
  1303. C
  1304. C
  1305. C  **********************************************
  1306. C  ***********  MULTIPLICATION  *****************
  1307. C  **********************************************
  1308. 3000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1309.     GOTO (3100,3200,3300,3300,3500,3600,3700,3300,3200),ID
  1310.     STOP 3000
  1311. C
  1312. C
  1313. C  ASCII (ALSO SUBTRACTION, MULTIPLICATION AND DIVISION)
  1314. 3100    CALL ERRMSG (12)
  1315.     GOTO 9999
  1316. C
  1317. C
  1318. C  DECIMAL, REAL
  1319. 3200    DO 3204 I=1,8
  1320. 3204    EIGHT(I)=STACK1(I,PT1)
  1321.     RHOLD=REAL
  1322.     DO 3208 I=1,8
  1323. 3208    EIGHT(I)=STACK2(I,PT2)
  1324.     REAL=RHOLD*REAL
  1325. 3209    DO 3210 I=1,8
  1326. 3210    STACK1(I,PT1)=EIGHT(I)
  1327. C
  1328. C
  1329. C  FOLLOWING USED BY OTHER SECTIONS
  1330. 3220    ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,3))
  1331.     GOTO 10000
  1332. C
  1333. C
  1334. C
  1335. C  HEX,INTEGER,OCTAL
  1336. 3300    DO 3304 I=1,4
  1337. 3304    FOUR(I)=STACK1(I,PT1)
  1338.     IHOLD=INT
  1339.     DO 3308 I=1,4
  1340. 3308    FOUR(I)=STACK2(I,PT2)
  1341.     INT=IHOLD*INT
  1342. 3309    DO 3310 I=1,4
  1343. 3310    STACK1(I,PT1)=FOUR(I)
  1344.     GOTO 3220
  1345. C
  1346. C
  1347. C
  1348. C  M10
  1349. 3500    continue
  1350. c3500    CALL MULMUL (PT1,PT2,RETCD2,10)
  1351. C
  1352. C
  1353. C  FOLLOWING USED BY OTHER SECTIONS
  1354. 3510    IF (RETCD2.EQ.2) GOTO 9999
  1355.     GOTO 3220
  1356. C
  1357. C
  1358. C
  1359. C  M8
  1360. 3600    continue
  1361. c3600    CALL MULMUL (PT1,PT2,RETCD2,8)
  1362.     GOTO 3510
  1363. C
  1364. C
  1365. C
  1366. C  M16
  1367. 3700    continue
  1368. c3700    CALL MULMUL (PT1,PT2,RETCD2,16)
  1369.     GOTO 3510
  1370. C
  1371. C
  1372. C  **************************************************
  1373. C  ******************  DIVISION  ********************
  1374. C  **************************************************
  1375. 4000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1376.     GOTO (3100,4200,4300,4300,4500,4600,4700,4300,4200),ID
  1377.     STOP 4000
  1378. C
  1379. C
  1380. C  DECIMAL,REAL
  1381. 4200    DO 4204 I=1,8
  1382. 4204    EIGHT(I)=STACK1(I,PT1)
  1383.     RHOLD=REAL
  1384.     DO 4208 I=1,8
  1385. 4208    EIGHT(I)=STACK2(I,PT2)
  1386.     IF(REAL.NE.0.D0)GO TO 4210
  1387.     CALL ERRMSG(23)
  1388.     GO TO 9999
  1389. 4210    REAL=RHOLD/REAL
  1390.     GOTO 3209
  1391. C
  1392. C
  1393. C  HEX,INTEGER,OCTAL
  1394. 4300    DO 4304 I=1,4
  1395. 4304    FOUR(I)=STACK1(I,PT1)
  1396.     IHOLD=INT
  1397.     DO 4308 I=1,4
  1398. 4308    FOUR(I)=STACK2(I,PT2)
  1399.     IF(INT.NE.0)GO TO 4310
  1400.     CALL ERRMSG(23)
  1401.     GO TO 9999
  1402. 4310    INT=IHOLD/INT
  1403.     GOTO 3309
  1404. C
  1405. C
  1406. C  M10
  1407. 4500    continue
  1408. c4500    CALL MULDIV (PT1,PT2,RETCD2,10)
  1409.     GOTO 3510
  1410. C
  1411. C
  1412. C  M8
  1413. 4600    continue
  1414. c4600    CALL MULDIV (PT1,PT2,RETCD2,8)
  1415.     GOTO 3510
  1416. C
  1417. C
  1418. C  M16
  1419. 4700    continue
  1420. c4700    CALL MULDIV (PT1,PT2,RETCD2,16)
  1421.     GOTO 3510
  1422. C
  1423. C
  1424. C
  1425. C
  1426. C
  1427. C **************************************************
  1428. C *****************  ADDITION  *********************
  1429. C **************************************************
  1430. C
  1431. 5000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1432.     GOTO (3100,5200,5300,5300,5500,5600,5700,5300,5200),ID
  1433.     STOP 5000
  1434. C
  1435. C
  1436. C  DECIMAL, REAL
  1437. 5200    DO 5204 I=1,8
  1438. 5204    EIGHT(I)=STACK1(I,PT1)
  1439.     RHOLD=REAL
  1440.     DO 5208 I=1,8
  1441. 5208    EIGHT(I)=STACK2(I,PT2)
  1442.     REAL=RHOLD+REAL
  1443.     GOTO 3209
  1444. C
  1445. C
  1446. C  HEX,INTEGER,OCTAL
  1447. 5300    DO 5304 I=1,4
  1448. 5304    FOUR(I)=STACK1(I,PT1)
  1449.     IHOLD=INT
  1450.     DO 5308 I=1,4
  1451. 5308    FOUR(I)=STACK2(I,PT2)
  1452.     INT=IHOLD+INT
  1453.     GOTO 3309
  1454. C
  1455. C
  1456. C  M10
  1457. 5500    continue
  1458. c5500    CALL MULADD (PT1,PT2,RETCD2,1)
  1459.     GOTO 3510
  1460. C
  1461. C
  1462. C  M8
  1463. 5600    continue
  1464. c5600    CALL MULADD (PT1,PT2,RETCD2,2)
  1465.     GOTO 3510
  1466. C
  1467. C
  1468. C  M16
  1469. 5700    continue
  1470. c5700    CALL MULADD(PT1,PT2,RETCD2,3)
  1471.     GOTO 3510
  1472. C
  1473. C
  1474. C
  1475. C
  1476. C
  1477. C
  1478. C  ***************************************************
  1479. C  ******************  SUBTRACTION  ******************
  1480. C  ***************************************************
  1481. C
  1482. 6000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1483.     GOTO (3100,6200,6300,6300,6500,6600,6700,6300,6200),ID
  1484.     STOP 6000
  1485. C
  1486. C
  1487. C  DECIMAL,REAL
  1488. 6200    DO 6204 I=1,8
  1489. 6204    EIGHT(I)=STACK1(I,PT1)
  1490.     RHOLD=REAL
  1491.     DO 6208 I=1,8
  1492. 6208    EIGHT(I)=STACK2(I,PT2)
  1493.     REAL=RHOLD-REAL
  1494.     GOTO 3209
  1495. C
  1496. C
  1497. C  HEX,INTEGER,OCTAL
  1498. 6300    DO 6304 I=1,4
  1499. 6304    FOUR(I)=STACK1(I,PT1)
  1500.     IHOLD=INT
  1501.     DO 6308 I=1,4
  1502. 6308    FOUR(I)=STACK2(I,PT2)
  1503.     INT=IHOLD-INT
  1504.     GOTO 3309
  1505. C
  1506. C
  1507. C  M10
  1508. 6500    continue
  1509. c6500    CALL MULADD (PT1,PT2,RETCD2,4)
  1510.     GOTO 3510
  1511. C
  1512. C
  1513. C  M8
  1514. 6600    continue
  1515. c6600    CALL MULADD (PT1,PT2,RETCD2,5)
  1516.     GOTO 3510
  1517. C
  1518. C
  1519. C  M16
  1520. 6700    continue
  1521. c6700    CALL MULADD (PT1,PT2,RETCD2,6)
  1522.     GOTO 3510
  1523. C
  1524. C
  1525. C
  1526. C
  1527. C
  1528. C    EXIT
  1529. 9999    RETCD=3
  1530. C
  1531. C
  1532. C
  1533. 10000    ST2PT=ST2PT-2
  1534.     RETURN
  1535.     END
  1536. c -h- calc.for    Fri Aug 22 13:00:17 1986    
  1537.     SUBROUTINE CALC
  1538. C COPYRIGHT (C) 1983 GLENN EVERHART
  1539. C ALL RIGHTS RESERVED
  1540. C 60=MAX REAL ROWS
  1541. C 301=MAX REAL COLS
  1542. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  1543. C VBLS AND TYPE DIMENSIONED 60,301
  1544. C ***               CALC   MAINLINE                   ***
  1545. C
  1546. C THIS PROGRAM EVALUATES ARITHMETIC EXPRESSIONS INPUT TO IT
  1547. C AND ALLOWS VARIABLES TO BE ASSIGNED VALUES. IT FEATURES
  1548. C MULTIPLE PRECISION ARITHMETIC IN BASE 10, OCTAL, AND
  1549. C HEXADECIMAL. SEE CALC.MEM FOR A COMPLETE DESCRIPTION IN
  1550. C THE FORM OF A USERS GUIDE. TYPE ? TO OBTAIN A LIST OF
  1551. C POSSIBLE COMMANDS.
  1552. C
  1553. C    CALC CALLS
  1554. C
  1555. C  ASSIGN    OPENS A FILE AND ASSIGNS IT TO A LOGICAL I/O UNIT.
  1556. C  CLOSE     CLOSES A FILE ASSOCIATED WITH A LOGICAL I/O UNIT.
  1557. C  CMND      DETERMINES WHAT CALC COMMAND IS REQUIRED.
  1558. C  ERRCX     CHECKS THE EXPRESSION IN AN INPUT LINE FOR SYNTAX ERRORS.
  1559. C  ERRMSG    PRINTS OUT ERROR MESSAGES.
  1560. C  EXIT      RETURNS TO OPERATING SYSTEM.
  1561. C  GETMCR    GETS THE COMMAND LINE USED TO INVOKE CALC. IF AN ARGUMENT
  1562. C            IS PRESENT, CALC EXITS AFTER THAT ONE COMMAND IS EXECUTED.
  1563. C  INPOST    CONVERTS AN INFIX EXPRESSION TO POSTFIX FORM.
  1564. C  LIST      LISTS THE LEGAL CALC COMMANDS.
  1565. C  POSTVL    CONVERTS AN EXPRESSION IN POSTFIX NOTATION ON STACK 1 TO
  1566. C            A VALUE.
  1567. C  SLEND     FINDS THE LAST NON-BLANK IN LINE(80).
  1568. C  VAROUT    PRINTS OUT THE VALUE OF A VARIABLE.
  1569. C  ZNEG      DETERMINES IF A VARIABLE IS POSITIVE IN VALUE
  1570. C
  1571. C
  1572. C
  1573. C   VARIABLE      USE
  1574. C
  1575. C  BASED        DEFAULT BASE WHEN CONSTANTS ARE ENTERED.
  1576. C  BLANK        ' '
  1577. C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
  1578. C               SECOND SUBSCRIPT IS
  1579. C                     1 FOR DECIMAL
  1580. C                     2 FOR OCTAL
  1581. C                     3 FOR HEXADECIMAL
  1582. C  I,J          HOLD TEMPORARY VALUES.
  1583. C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
  1584. C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
  1585. C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
  1586. C               USED TO CONTROL ITERATION.
  1587. C        THIS VARIABLE IS GUARANTEED TO BE 1-27.
  1588. C  LEND         POINTS TO LAST NON-BLANK CHARACTER IN LINE(80)
  1589. C  LEVEL        HOLDS THE LOGICAL I/O UNIT WHERE THE NEXT CALC COMMAND
  1590. C               LINES COME FROM.
  1591. C  LINE(80)     COMMAND INPUT LINE.
  1592. C  NONBLK       POINTS TO LAST NON-BLANK FOUND IN LINE(80).
  1593. C  ONCE         HOLDS 1 IF ONLY ONE COMMAND LINE IS TO BE EXECUTED,
  1594. C               0 OTHERWISE.
  1595. C  STAR         '*'
  1596. C  VIEWSW           VIEW SWITCH
  1597. C                    0 = OUTPUT ERROR MESSAGES
  1598. C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
  1599. C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
  1600. C                        EVALUATED.
  1601. C                    3 = OUTPUT EVERYTHING
  1602. C  WHAT         '?' SIGNIFIES THAT A LIST OF POSSIBLE COMMANDS
  1603. C               SHOULD BE OUTPUT.
  1604. C
  1605. C    MODIFIED    REASON
  1606. C
  1607. C    18-MAY-1981    DELETED LINE THAT CAUSED DEFAULT BASE TO BE RESET
  1608. C            WHEN AN ERROR OCCURS (PB)
  1609. C
  1610. C    18-MAY-1981    ADDED CODE AT LINES 106 TO 108 TO CONVERT FROM LOWER
  1611. C            TO UPPER CASE  (PB)
  1612. C
  1613. C CHANGED TO SUBROUTINE GCE TO ALLOW EXTERNAL CONTROL OF CALCULATOR.
  1614. C
  1615.     InTeGer*4 LEVEL,NONBLK,LEND
  1616.     InTeGer*4 RETCD,VIEWSW,BASED
  1617.     InTeGer*4 ONCE
  1618.     InTeGer*4 ZNEG,ITCNTV(6)
  1619. C
  1620.     CHARACTER*1  LINE(80),WHAT,STAR,QUOTE
  1621.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  1622.     CHARACTER*1 DIGITS(16,3)
  1623.     CHARACTER*1 OARRY(100)
  1624.     InTeGer*4 OSWIT,OCNTR
  1625. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  1626. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  1627.     InTeGer*4 IPS1,IPS2,MODFLG
  1628. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  1629.        InTeGer*4 XTCFG,IPSET,XTNCNT
  1630.        CHARACTER*1 XTNCMD(80)
  1631. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  1632. C VARY FLAG ITERATION COUNT
  1633.     INTEGER KALKIT
  1634. C    COMMON/VARYIT/KALKIT
  1635.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  1636.     InTeGer*4 RCMODE,IRCE1,IRCE2
  1637. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1638. C     1  IRCE2
  1639. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  1640. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  1641. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  1642. C RCFGX ON.
  1643. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  1644. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  1645. C  AND VM INHIBITS. (SETS TO 1).
  1646.     INTEGER*4 FH
  1647. C FILE HANDLE FOR CONSOLE I/O (RAW)
  1648. C    COMMON/CONSFH/FH
  1649.     CHARACTER*1 ARGSTR(52,4)
  1650. C    COMMON/ARGSTR/ARGSTR
  1651.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  1652.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  1653.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1654.      3  IRCE2,FH,ARGSTR
  1655.     InTeGer*4 ILNFG,ILNCT
  1656.     CHARACTER*1 ILINE(106)
  1657.     COMMON/ILN/ILNFG,ILNCT,ILINE
  1658. C
  1659.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  1660.     InTeGer*4 RRWACT,RCLACT
  1661. C    COMMON/RCLACT/RRWACT,RCLACT
  1662.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  1663.      1  IDOL7,IDOL8
  1664. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  1665. C     1  IDOL7,IDOL8
  1666.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  1667. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  1668.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1669. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1670. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  1671. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  1672.     InTeGer*4 KLVL
  1673. C    COMMON/KLVL/KLVL
  1674.     InTeGer*4 IOLVL,IGOLD
  1675. C    COMMON/IOLVL/IOLVL
  1676. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  1677. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  1678.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  1679.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  1680.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  1681.      3  k3dfg,kcdelt,krdelt,kpag
  1682. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  1683. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  1684. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  1685. C    COMMON/KLVL/KLVL
  1686.     COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  1687.     COMMON /DIGV/ DIGITS
  1688.     COMMON/ITERA/ITCNTV
  1689.     Character*2 crlf
  1690.     character*127 cwrk
  1691. C
  1692.     DATA  WHAT/'?'/, STAR/'*'/, QUOTE/''''/
  1693.     DATA ONCE/0/
  1694. C
  1695.     crlf(1:1)=char(13)
  1696.     crlf(2:2)=char(10)
  1697. C
  1698. C
  1699. C LOGICAL I/O UNIT 1 IS ASSIGNED TO THE INVOKING TERMINAL
  1700. C IF YOU DON'T WANT TO RISK THE BUILDER TASK BUILDING (LINKING)
  1701. C THE MODULES PROPERLY, PUT IN A
  1702.     IF(KLVL.EQ.1)LEVEL=KLVL
  1703.     ONCE=0
  1704. C    IF(ILNFG.NE.0) GOTO 6000
  1705. C    CALL ASSIGN (1,'TT:')
  1706. 6000    CONTINUE
  1707. C CHANGE TI: TO TT: FOR VMS.
  1708. C
  1709.     IF(ILNFG.EQ.0)GOTO 6010
  1710.     IF(ILNCT.GT.0)GOTO 6010
  1711. C INVALID INPUTS...NO LINE TO DO BUT FLAGGED TO DO. CLEAN UP.
  1712.     ILNFG=0
  1713.     RETURN
  1714. 6010    CONTINUE
  1715.     IF(ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6001
  1716. C ++++++
  1717. C FOR DEC FORTRAN:
  1718. C    CALL GETMCR(LINE,LEND)
  1719. C    IF(LEND)20,20,5
  1720. C FOR NON-DEC FORTRAN: (OR VAX VERSIONS)
  1721.     GOTO 20
  1722. C ++++++  END OF CHOICES...
  1723. 5    CONTINUE
  1724.     GOTO 6003
  1725. 6001    CONTINUE
  1726.     DO 6007 LENDX=1,80
  1727. 6007    LINE(LENDX)=CHAR(32)
  1728.     IF(ILNFG.EQ.1)ONCE=1
  1729.     I255X=0
  1730.     DO 6002 LENDX=1,ILNCT
  1731.     LINE(LENDX)=ILINE(LENDX)
  1732.     IF(ICHAR(LINE(LENDX)).EQ.255)I255X=3
  1733.     IF(I255X.LE.0)GOTO 4602
  1734.     I255X=I255X-1
  1735.     GOTO 6002
  1736. C SKIP ENTIRE 3-CHR PACKED CODES
  1737. 4602    CONTINUE
  1738.     IF(ICHAR(LINE(LENDX)).GT.0.AND.ICHAR(LINE(LENDX)).LT.32)
  1739.      1  LINE(LENDX)=CHAR(32)
  1740. C LEAVE ANY EXISTING NULLS IN.
  1741. 6002    CONTINUE
  1742.     LEND=ILNCT
  1743. CD    CALL FRMEDT(LINE,LEND)
  1744. C FRMEDT IMPLEMENTS EDITS OF {VAR INTO THAT VARIABLE'S FORMULA
  1745. CC NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
  1746. C    ICCC=MIN0(80,(LEND+1))
  1747. C    LINE(ICCC)=0
  1748.     GOTO 103
  1749. 6003    CONTINUE
  1750.     DO 6 NONBLK=1,7
  1751.     IF(LINE(NONBLK).EQ.BLANK)GO TO 7
  1752.     IF(ICHAR(LINE(NONBLK)).EQ.13)GO TO 20
  1753. 6    CONTINUE
  1754.     STOP 6
  1755. 7    NONBLK=NONBLK+1
  1756.     ONCE=1
  1757.     GO TO 106
  1758. C
  1759. C  ERROR RESET
  1760.  
  1761. 10    IF(LEVEL.LE.1) GO TO 12
  1762.     CLOSE(LEVEL)
  1763.     LEVEL=LEVEL-1
  1764.     GO TO 10
  1765. 12    CONTINUE
  1766.     VIEWSW=3
  1767. C
  1768. C
  1769. C  GET NEXT INPUT LINE
  1770. 20    CONTINUE
  1771.     LINE(1)=0
  1772.     LINE(2)=0
  1773.     IF(ONCE.EQ.1.AND.LEVEL.LE.1) RETURN
  1774. C20    IF(ONCE.EQ.1.AND.LEVEL.EQ.1) CALL EXIT
  1775. C    IF (ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6004
  1776.     IF (LEVEL.LE.1.AND.ILNFG.NE.0.AND.ILNCT.GT.0)RETURN
  1777.     IF(LEVEL.LT.1)RETURN
  1778.     IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)call vwrt(crlf,2)
  1779.     IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)call vwrt('Calc>',5)
  1780. c22    FORMAT(' CALC>')
  1781. C
  1782. C
  1783.     LLLV=LEVEL
  1784.     IF(LLLV.EQ.1)LLLV=11
  1785. c    rewind 11
  1786.     if(lllv.ne.11)goto 6008
  1787.     call vget(line,80)
  1788.     do 6009 iii=1,80
  1789. C Force chars read in to spaces like Fortran system would.
  1790. C This includes controls like crlf.
  1791.     if(ichar(line(iii)).le.31)line(iii)=' '
  1792. 6009    Continue
  1793. 6008    Continue
  1794. c    if(lllv.eq.11)call vget(line,80)
  1795.     if(lllv.ne.11)READ (LLLV,24,END=900,ERR=1000) LINE
  1796. c    rewind 11
  1797. 24    FORMAT (80A1)
  1798. C    GOTO 6005
  1799. C SECTION BELOW COMMENTED OUT BECAUSE IT SHOULD NEVER BE CALLED (GCE).
  1800. C6004    CONTINUE
  1801. C    DO 6006 LENDX=1,80
  1802. C6006    LINE(LENDX)=CHAR(32)
  1803. CC ABOVE BLANKS OUT LINE ARRAY
  1804. C    DO 6007 LENDX=1,ILNCT
  1805. C6007    LINE(LENDX)=ILINE(LENDX)
  1806. CC ABOVE COPIES INPUT FROM OUR CALLER...
  1807. C6005    CONTINUE
  1808. C
  1809. C
  1810. C
  1811. C FIND LAST NONBLANK, SAVE POSITION WITH VARIABLE 'LEND'
  1812. CD    CALL FRMEDT(LINE,LEND)
  1813.     CALL SLEND(RETCD)
  1814.     GO TO(30,20),RETCD
  1815.     STOP 30
  1816. 30    CONTINUE
  1817. C
  1818. C
  1819.     IF(ILNFG.EQ.0.AND.ILNCT.GT.0)GOTO 103
  1820. C SHOW WHAT WAS READ FROM FILE
  1821. c    rewind 11
  1822.     cwrk=' '
  1823.     IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
  1824.      1  write(cwrk,40)level,(line(i),i=1,lend)
  1825.     cwrk= crlf // cwrk
  1826.     iii=lend+10
  1827.     IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
  1828.      1  call vwrt(cwrk,iii)
  1829. c     1 WRITE(11,40)LEVEL,(LINE(I),I=1,LEND)
  1830. c    rewind 11
  1831. 40    FORMAT (' CALC<',I1,'>',80A1)
  1832. 103    CONTINUE
  1833. C NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
  1834.     ICCC=MIN0(80,(LEND+1))
  1835.     LINE(ICCC)=0
  1836. C
  1837. C  IDENTIFY FIRST NON-BLANK
  1838.     DO 104 NONBLK=1,LEND
  1839.     IF (LINE(NONBLK).NE.BLANK) GOTO 106
  1840. 104    CONTINUE
  1841.     RETURN
  1842. C    STOP 104
  1843. C
  1844. C CONVERT LOWER CASE TO UPPER CASE
  1845. 106    CONTINUE
  1846.     I255X=0
  1847.     DO 108 I=NONBLK,LEND
  1848.     J=ICHAR(LINE(I))
  1849.     IF(J.EQ.255)I255X=3
  1850.     IF(I255X.LE.0)GOTO 3107
  1851. C SKIP ENCODED VARIABLE NAMES
  1852.     I255X=I255X-1
  1853.     GOTO 107
  1854. 3107    CONTINUE
  1855.     IF (I.EQ.NONBLK) GOTO 107
  1856.     IF (LINE(I-1).EQ.QUOTE) GOTO 108
  1857.     IF(J.GE.97.AND.J.LE.122) LINE(I)=CHAR(J-32)
  1858. 107    CONTINUE
  1859. 108    CONTINUE
  1860. C
  1861. C  SEE IF A LIST OF POSSIBLE COMMANDS SHOULD BE PRINTED
  1862.     IF (LINE(NONBLK).NE.WHAT) GOTO 110
  1863.     CALL LIST
  1864.     GOTO 20
  1865. C
  1866. C  SEE IF IT IS A COMMAND
  1867. 110    IF (LINE(NONBLK).NE.STAR) GOTO 120
  1868.     CALL CMND (RETCD)
  1869.     GOTO (20,115,10,6120), RETCD
  1870. 6120    RETURN
  1871. C    STOP 110
  1872. C
  1873. C
  1874. C A READ COMMAND WAS EXECUTED SO LINE HOLDS THE NEW COMMAND LINE.
  1875. 115    CALL SLEND(RETCD)
  1876.     GO TO (103,20),RETCD
  1877.     RETURN
  1878. C    STOP 115
  1879. C
  1880. C  SEE IF ONLY ONE ALPHA CHARACTER
  1881. 120    J=NONBLK+1
  1882.     IF (LEND.NE.NONBLK) GOTO 130
  1883.     DO 124 I=1,27
  1884.     IF (LINE(NONBLK).EQ.ALPHA(I)) GOTO 126
  1885. 124    CONTINUE
  1886. C
  1887. C ALLOW FOR A SINGLE DIGIT TO BE ASSIGNED TO %
  1888.     DO 125 I=1,10
  1889.     IF(LINE(NONBLK).EQ.DIGITS(I,1))GO TO 130
  1890. 125    CONTINUE
  1891. C
  1892. C
  1893. C ALLOW FOR ENTERING THE ASCII BLANK
  1894.     IF(LINE(NONBLK).EQ.QUOTE)GO TO 130
  1895.     I=1
  1896.     GOTO 1001
  1897. C
  1898. C  OUTPUT VALUE OF SINGLE VARIABLE
  1899. 126    CALL VAROUT(I,1)
  1900.     GOTO 20
  1901. C
  1902. C
  1903. C CHECK INPUT FOR SYNTAX ERRORS
  1904. 130    CALL ERRCX (RETCD)
  1905.     GOTO (140,10),RETCD
  1906.     RETURN
  1907. C    STOP 130
  1908. C
  1909. C  CHANGE FROM INFIX TO POSTFIX NOTATION
  1910. 140    CALL INPOST (RETCD)
  1911.     GOTO (150,10), RETCD
  1912. C
  1913. C
  1914. C EVALUATE EXPRESSION
  1915. 150    CONTINUE
  1916.     CALL POSTVL(RETCD)
  1917.     GOTO(20,10),RETCD
  1918.     RETURN
  1919. C    STOP 150
  1920. C
  1921. C
  1922. C  EXIT
  1923. 900    CONTINUE
  1924.     IF (LEVEL.EQ.1) RETURN
  1925. C    IF (LEVEL.EQ.1) CALL EXIT
  1926.     IF(ITCNTV(LEVEL).EQ.0)GOTO 910
  1927.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GO TO 910
  1928. C
  1929. C VALUE OF ITERATION VARIABLE IS POSITIVE SO REWIND FILE
  1930. C AND EXECUTE AGAIN.
  1931.     REWIND LEVEL
  1932.     GO TO 20
  1933. C
  1934. C
  1935. C EXIT FROM THIS LEVEL BY CLOSING THE FILE AND DECREASING VALUE
  1936. C OF LEVEL BY ONE.
  1937. 910    CLOSE(LEVEL)
  1938.     LEVEL=LEVEL-1
  1939.     GOTO 20
  1940. C
  1941. C
  1942. C
  1943. C *** ERROR PROCESSING ***
  1944. 1000    I=27
  1945. 1001    CALL ERRMSG(I)
  1946.     GO TO 10
  1947.     END
  1948. c -h- calun.for    Fri Aug 22 13:00:17 1986    
  1949.     SUBROUTINE CALUN(RETCD)
  1950. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  1951. C ALL RIGHTS RESERVED
  1952. C 60=MAX REAL ROWS
  1953. C 301=MAX REAL COLS
  1954. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  1955.  
  1956. C VBLS AND TYPE DIMENSIONED 60,301
  1957. C  *****************************************************
  1958. C  *             SUBROUTINE   CALUN                    *
  1959. C  *****************************************************
  1960. C
  1961. C  SUBROUTINE CALUN PERFORMS A UNARY OPERATION.
  1962. C
  1963. C  UPON ENTRANCE:
  1964. C    OPERATOR IS ON STACK 2
  1965. C    OPERAND IS ON STACK 1
  1966. C  UPON EXIT:
  1967. C    OPERATOR HAS BEEN POPPED OFF STACK 2
  1968. C    RESULT IS ON STACK 1
  1969. C
  1970. C    RETCD    MEANING
  1971. C
  1972. C    1    O.K.
  1973. C    2    ERROR
  1974. C
  1975. C   MODIFICATION CLASSES: M3, M4, AND M8
  1976. C
  1977. C  CALUN CALLS
  1978. C
  1979. C  CONTYP   CONVERTS DATA TYPES
  1980. C  ERRMSG   PRINTS ERROR MESSAGES
  1981. C  $DATAN   ARC TANGENT
  1982. C  $DCOS    COSINE
  1983. C  $DEXP    E**X
  1984. C  $DLOG    NATURAL LOG
  1985. C  $DLOG10  LOG BASE 10
  1986. C  $DSIN    SINE
  1987. C  $DSQRT   SQUARE ROOT
  1988. C  $DTANH   HYPERBOLIC TANGENT
  1989. C
  1990. C  CALUN IS CALLED BY POSTVL WHICH CONVERTS FROM INFIX TO POSTFIX
  1991. C
  1992. C     VARIABLE    USE
  1993. C
  1994. C  RETCD      RETURN CODE:  1 = O.K.   2 = ERROR
  1995. C  J,K,K2,I   HOLD TEMPORARY VALUES
  1996. C  MINUS      VALUE IN LAST MULTIPLE PRECISION BYTE.
  1997. C             USED TO INDICATE A NEGATIVE NUMBER.
  1998. C  PLUS       VALUE IN LAST MULTIPLE PRCISION BYTE.
  1999. C             USED TO INDICATE A POSITIVE NUMBER.
  2000. C  REAL       TEMPORARY DOUBLE PRECISION VALUES.
  2001. C  INT        TEMPORARY INTEGER*4 VALUES.
  2002. C  ST1TYP(40) TYPE FOR EACH ELEMENT ON STACK 1
  2003. C  ST2TYP(40) TYPE FOR EACH ELEMENT OF STACK 2
  2004. C  ST1PT      POINTS TO TOP OF STACK 1
  2005. C  ST2PT      POINTS TO TOP OF STACK 2
  2006. C  STACK1     HOLDS OPERAND
  2007. C  STACK2     HOLDS UNARY OPERATOR
  2008. C
  2009. C    SUBROUTINE CALUN(RETCD)
  2010.     REAL*8 REAL
  2011.     REAL*8 DABS,DEXP,DLOG,DLOG10,DSQRT,DSIN,DCOS
  2012.     REAL*8 DASIN,DACOS,DTAN
  2013.     REAL*8 DTANH,DATAN
  2014. C
  2015.     REAL*4 FLOAT
  2016. C
  2017.     INTEGER*4 INT
  2018. C
  2019.     InTeGer*4 RETCD,RETCD2
  2020.     InTeGer*4 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT,ST1LIM,ST2LIM
  2021.     InTeGer*4 K,K2
  2022. C
  2023.     CHARACTER*1 STACK1(8,40),STACK2(8,40),FOUR(4),EIGHT(8)
  2024.     CHARACTER*1 PLUS,MINUS
  2025. C
  2026.     EQUIVALENCE (FOUR,INT),(EIGHT,REAL)
  2027. C
  2028.     COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,
  2029.      ;          ST1TYP,ST2TYP,ST1LIM,ST2LIM
  2030. C
  2031. C    DATA PLUS/0/,MINUS/1/
  2032. C
  2033.     PLUS=0
  2034.     MINUS=1
  2035.     RETCD=1
  2036.     K=ST2TYP(ST2PT-1)
  2037.     K2=ST1TYP(ST1PT-1)
  2038. C
  2039. C
  2040. C MAKE SURE VARIABLE IS DEFINED
  2041.     IF(K2.GT.0)GOTO 50
  2042. C IF NOT, PRINT MESSAGE AND RETURN
  2043.     CALL ERRMSG(16)
  2044.     GOTO 89999
  2045. C
  2046. 50    J=K
  2047. C
  2048. C
  2049. C SEE IF IT IS A UNARY MINUS
  2050.     IF (J.EQ.111) GOTO 100
  2051. C
  2052. C
  2053. C  FUNCTIONS START AT 31
  2054.     K=K-30
  2055.     GOTO (100,100,300,400,500,400,10000),K
  2056.     GOTO 10000
  2057. C
  2058. C
  2059. C  ***************************************
  2060. C  *** ABS (=DABS), IABS, AND UNARY -  ***
  2061. C  ***************************************
  2062. 100    CONTINUE
  2063.     IF(K2.GT.0)GO TO 105
  2064.     CALL ERRMSG(16)
  2065.     GO TO 89999
  2066. 105    GOTO (110,120,130,130,140,140,140,130,120),K2
  2067.     STOP 100
  2068. C
  2069. C
  2070. C  ASCII
  2071. 110    CALL ERRMSG (12)
  2072.     GOTO 89999
  2073. C
  2074. C
  2075. C  DECIMAL AND REAL
  2076. 120    DO 121 I=1,8
  2077. 121    EIGHT(I)=STACK1(I,ST1PT-1)
  2078.     IF (K.NE.111) GOTO 123
  2079. C
  2080. C
  2081. C  UNARY -
  2082.     REAL=-REAL
  2083.     GOTO 124
  2084. 123    REAL=DABS(REAL)
  2085. 124    DO 125 I=1,8
  2086. 125    STACK1(I,ST1PT-1)=EIGHT(I)
  2087.     GOTO 90000
  2088. C
  2089. C
  2090. C  INTEGER, HEXADECIMAL, AND OCTAL
  2091. 130    DO 131 I=1,4
  2092. 131    FOUR(I)=STACK1(I,ST1PT-1)
  2093.     IF (K.NE.111) GOTO 133
  2094.     INT=-INT
  2095.     GO TO 134
  2096. 133    IF(INT.LT.0)INT=-INT
  2097. 134    DO 135 I=1,4
  2098. 135    STACK1(I,ST1PT-1)=FOUR(I)
  2099.     GOTO 90000
  2100. C
  2101. C
  2102. C  MULTIPLE PRECISION
  2103. 140    IF (K.NE.111) GOTO 150
  2104.     IF (STACK1(8,ST1PT-1).EQ.PLUS)GOTO 160
  2105. 150    STACK1(8,ST1PT-1)=PLUS
  2106.     GOTO 90000
  2107. 160    STACK1(8,ST1PT-1)=MINUS
  2108.     GOTO 90000
  2109. C
  2110. C
  2111. C  ***************************************
  2112. C  ************  FLOAT  ******************
  2113. C  ***************************************
  2114. 300    CONTINUE
  2115.     GOTO (310,320,330,330,340,340,340,330,320),K2
  2116. C
  2117. C
  2118. C  ASCII
  2119. 310    CALL ERRMSG(12)
  2120.     GOTO 89999
  2121. C
  2122. C
  2123. C  REAL (=DECIMAL)
  2124. 320    CALL ERRMSG (13)
  2125.     GOTO 89999
  2126. C
  2127. C
  2128. C  INTEGER=HEXADECIMAL=OCTAL
  2129. 330    DO 333 I=1,4
  2130. 333    FOUR(I)=STACK1(I,ST1PT-1)
  2131.     REAL=FLOAT(INT)
  2132.     DO 335 I=1,8
  2133. 335    STACK1(I,ST1PT-1)=EIGHT(I)
  2134.     ST1TYP(ST1PT-1)=2
  2135.     GOTO 90000
  2136. C
  2137. C
  2138. C  MULTIPLE PRECISION
  2139. 340    CALL ERRMSG (11)
  2140.     GOTO 89999
  2141. C
  2142. C
  2143. C
  2144. C  ***************************************
  2145. C  *******  IFIX AND INT (=IDINT)  *******
  2146. C  ***************************************
  2147. 400    CONTINUE
  2148.     GOTO (410,420,430,430,440,440,440,430,420),K2
  2149.     STOP 400
  2150. C
  2151. C
  2152. C  ASCII
  2153. 410    CALL ERRMSG (12)
  2154.     GOTO 89999
  2155. C
  2156. C
  2157. C  REAL AND DECIMAL
  2158. 420    DO 421 I=1,8
  2159. 421    EIGHT(I)=STACK1(I,ST1PT-1)
  2160.     INT=IDINT(REAL)
  2161.     DO 424 I=1,4
  2162. 424    STACK1(I,ST1PT-1)=FOUR(I)
  2163.     ST1TYP(ST1PT-1)=4
  2164.     GOTO 90000
  2165. C
  2166. C
  2167. C  INTEGER, HEXADECIMAL, AND OCTAL
  2168. 430    CALL ERRMSG (10)
  2169.     GOTO 89999
  2170. C
  2171. C
  2172. C  MULTIPLE PRECISION
  2173. 440    CALL ERRMSG (11)
  2174.     GOTO 89999
  2175. C
  2176. C
  2177. C
  2178. C  ***************************************
  2179. C  ***************  AINT  ****************
  2180. C  ***************************************
  2181. C
  2182. C  REAL TO REAL TRUNCATION
  2183. 500    CONTINUE
  2184.     GOTO (510,520,530,530,540,540,540,530,520),K2
  2185. C
  2186. C
  2187. C  ASCII
  2188. 510    CALL ERRMSG (12)
  2189.     GOTO 89999
  2190. C
  2191. C
  2192. C  REAL AND DECIMAL
  2193. 520    DO 522 I=1,8
  2194. 522    EIGHT(I)=STACK1(I,ST1PT-1)
  2195. C
  2196. C DON'T USE AINT(SNGL(REAL)) BECAUSE THEN
  2197. C 2.9999999 RESULTS IN 3.0
  2198.     REAL=DINT(REAL)
  2199.     DO 524 I=1,8
  2200. 524    STACK1(I,ST1PT-1)=EIGHT(I)
  2201.     GOTO 90000
  2202. C
  2203. C
  2204. C  INTEGER, HEXADECIMAL, AND OCTAL
  2205. 530    CALL ERRMSG (10)
  2206.     GOTO 89999
  2207. C
  2208. C
  2209. C  MULTIPLE PRECISION
  2210. 540    CALL ERRMSG(11)
  2211.     GOTO 89999
  2212. C
  2213. C
  2214. C
  2215. C
  2216. C  ****************************************
  2217. C  ****************************************
  2218. C  ********                        ********
  2219. C  ******** REAL TO REAL FUNCTIONS ********
  2220. C  ********                        ********
  2221. C  ********  EXP      (=DEXP)      ********
  2222. C  ********  ALOG     (=DLOG)      ********
  2223. C  ********  ALOG10   (=DLOG10)    ********
  2224. C  ********  SQRT     (=DSQRT)     ********
  2225. C  ********  SIN      (=DSIN)      ********
  2226. C  ********  COS      (=DCOS)      ********
  2227. C  ********  TANH     (DTANH)      ********
  2228. C  ********  ATAN     (=DATAN)     ********
  2229. C  ********                        ********
  2230. C  ****************************************
  2231. C  ****************************************
  2232. C
  2233. C
  2234. C
  2235. 10000    CONTINUE
  2236.     GOTO (11000,12000,15000,15000,15000,15000,15000,15000,12000),K2
  2237.     STOP 10000
  2238. C
  2239. C
  2240. C  ASCII
  2241. 11000    CALL ERRMSG (12)
  2242.     GOTO 89999
  2243. C
  2244. C
  2245. C  REAL AND DECIMAL
  2246. 12000    DO 12010 I=1,8
  2247. 12010    EIGHT(I)=STACK1(I,ST1PT-1)
  2248.     K=K-6
  2249.     GOTO (12100,12200,12300,12400,12500,12600,12700,12800,
  2250.      1  12840,12860,12880),K
  2251. C
  2252. C
  2253. C  EXP
  2254. 12100    REAL=DEXP(REAL)
  2255.     GOTO 14000
  2256. C
  2257. C
  2258. C  ALOG
  2259. 12200    REAL=DLOG(REAL)
  2260.     GOTO 14000
  2261. C
  2262. C
  2263. C  DLOG10
  2264. 12300    REAL=DLOG10(REAL)
  2265.     GOTO 14000
  2266. C
  2267. C
  2268. C  DSQRT
  2269. 12400    IF (REAL.GE.0.D0) GOTO 12410
  2270. 12405    CALL ERRMSG (14)
  2271.     GOTO 89999
  2272. 12410    REAL=DSQRT (REAL)
  2273.     GOTO 14000
  2274. C
  2275. C
  2276. C  DSIN
  2277. 12500    REAL=DSIN(REAL)
  2278.     GOTO 14000
  2279. C
  2280. C
  2281. C  DCOS
  2282. 12600    REAL=DCOS(REAL)
  2283.     GOTO 14000
  2284. C
  2285. C
  2286. C  DTANH
  2287. 12700    REAL=DTANH(REAL)
  2288.     GOTO 14000
  2289. C
  2290. C
  2291. C  DATAN
  2292. 12800    REAL=DATAN(REAL)
  2293.     GOTO 14000
  2294. C
  2295. C ASIN
  2296. 12840    CONTINUE
  2297.     IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
  2298.     REAL=DASIN(REAL)
  2299.     GOTO 14000
  2300. C
  2301. C ACOS
  2302. 12860    CONTINUE
  2303.     IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
  2304.     REAL=DACOS(REAL)
  2305.     GOTO 14000
  2306. C
  2307. C TAN
  2308. 12880    CONTINUE
  2309.     IF(REAL.GT.1.570795)REAL=1.570795
  2310.     IF(REAL.LT. -1.570795) REAL = -1.570795
  2311. C CLAMP TO AVOID OVERFLOW
  2312.     REAL=DTAN(REAL)
  2313. C    GOTO 14000
  2314. C (GOTO NOT NEEDED IF THIS IS THE LAST FUNCTION)
  2315. 14000    DO 14010 I=1,8
  2316. 14010    STACK1(I,ST1PT-1)=EIGHT(I)
  2317.     GOTO 90000
  2318. C
  2319. C
  2320. C  INTEGER, HEXADECIMAL, OCTAL, AND MULTIPLE PRECISION
  2321. 15000    CONTINUE
  2322.     CALL CONTYP(STACK1,ST1PT-1,K2,2,RETCD2)
  2323.     GO TO(15010,89999),RETCD2
  2324.     STOP 15000
  2325. 15010    ST1TYP(ST1PT-1)=2
  2326.     GO TO 12000
  2327. C
  2328. C
  2329. C  EXIT
  2330. 89999    RETCD=2
  2331. 90000    ST2PT=ST2PT-1
  2332.     RETURN
  2333.     END
  2334. c -h- ce2a.fms    Fri Aug 22 13:00:17 1986    
  2335.     SUBROUTINE CE2A(LNIN,LNOUT)
  2336. C CONVERT ENCODED FORMULAS TO NORMAL ASCII
  2337. C NOTE: ONLY HAS TO HANDLE STANDARD NAMES AS A$5$ TYPE FORMS AND P# AND D# FORMS
  2338. C ARE NOT TRANSLATED TO PACKED ONES.
  2339.     CHARACTER*1 NAME(4),NUMBER(6)
  2340.     CHARACTER*1 LNIN,LNOUT
  2341.     CHARACTER*6 NUMBR6
  2342.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  2343.     DIMENSION LNIN(128),LNOUT(128)
  2344. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2345. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2346.     InTeGer*4 RRWACT,RCLACT
  2347. C    COMMON/RCLACT/RRWACT,RCLACT
  2348.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2349.      1  IDOL7,IDOL8
  2350. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2351. C     1  IDOL7,IDOL8
  2352.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2353. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2354.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2355. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2356. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2357. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2358.     InTeGer*4 KLVL
  2359. C    COMMON/KLVL/KLVL
  2360.     InTeGer*4 IOLVL,IGOLD
  2361. C    COMMON/IOLVL/IOLVL
  2362. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2363. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2364.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2365.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2366.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  2367.      3  k3dfg,kcdelt,krdelt,kpag
  2368. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2369. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2370. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2371. C    LOGICAL*2 L63,L192,L255,L127
  2372.     LOGICAL*4 L1,L2
  2373. C    InTeGer*4 I63,I192,I255,I127
  2374.     InTeGer*4 I63,I192,I127
  2375.     InTeGer*4 I1,I2
  2376. C    EQUIVALENCE(L127,I127)
  2377. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  2378.     EQUIVALENCE (I1,L1),(I2,L2)
  2379.     INTEGER*4 FNAM(25)
  2380.     character*4 fnmx(25)
  2381.     CHARACTER*1 FCHNM(4,25)
  2382.     equivalence(fnmx(1)(1:1),fnam(1),fchnm(1,1))
  2383. c    EQUIVALENCE(FNAM(1),FCHNM(1,1))
  2384.     DATA FNMX/'MIN ','MAX ','AVG ','SUM ','STD ','IF  ',
  2385.      1  'AND ','IOR ','NOT ','CNT ','NPV ','LKP ',
  2386.      2  'LKN ','LKE ','XOR ','EQV ','MOD ','REM ','SGN ','IRR ',
  2387.      3  'RND ','PMT','PVL','AVE','CHS'/
  2388. C    DATA I63/63/,I192/192/,I255/255/,I128/128/
  2389.     DATA I63/63/,I192/192/,I127/127/
  2390.     LI=1
  2391.     LO=1
  2392. C LI = INPUT LOCATION
  2393. C LO=OUTPUT LOCATION
  2394. 100    CONTINUE
  2395.     LCC=ICHAR(LNIN(LI))
  2396.     IF(LCC.NE.255)GOTO 200
  2397. C FIND BINARY PATTERNS TO USE
  2398.     I1=ICHAR(LNIN(LI+1))
  2399.     I2=IMASK(I1,I192)
  2400. C    L2=L1.AND.L192
  2401.     I1=IMASK(I1,I63)
  2402. C    L1=L1.AND.L63
  2403.     ID1=I1
  2404.     I1=ICHAR(LNIN(LI+2))
  2405.     I1=IMASK(I1,I127)
  2406. C    L1=L1.AND.L127
  2407.     ID2=I2*2+I1
  2408.     LI=MIN0(LI+3,109)
  2409. C DO MASKING TO GET BINARY COORDS
  2410.     CALL IN2AS(ID1,NAME)
  2411. C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
  2412.     IL2=ID2-1
  2413.     WRITE(NUMBR6(1:6),1000)IL2
  2414. C    ENCODE(6,1000,NUMBER)IL2
  2415. 1000    FORMAT(I6)
  2416. C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
  2417. C THROW OUT SPACES AND COPY THE REST.
  2418.     DO 202 N=1,4
  2419.     IF(ICHAR(NAME(N)).LE.32)GOTO 202
  2420.     LNOUT(LO)=NAME(N)
  2421.     LO=LO+1
  2422.     IF(LO.GT.110)GOTO 300
  2423. 202    CONTINUE
  2424.     DO 203 N=1,6
  2425.     IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
  2426. C IF 32 ISN'T SPACE, LOSE
  2427.     LNOUT(LO)=NUMBER(N)
  2428.     LO=LO+1
  2429.     IF(LO.GT.110)GOTO 300
  2430. 203    CONTINUE
  2431.     GOTO 300
  2432. C COPY MISC. CHARACTER
  2433. 200    CONTINUE
  2434.     II=ICHAR(LNIN(LI))
  2435.     IF(II.LT.230.OR.II.GT.254)GOTO 220
  2436. C FUNCTION NAME...
  2437.     II=II-229
  2438.     LNOUT(LO)=FCHNM(1,II)
  2439.     LNOUT(LO+1)=FCHNM(2,II)
  2440.     LNOUT(LO+2)=FCHNM(3,II)
  2441.     LI=LI+1
  2442.     LO=LO+3
  2443. C FILL IN ASCII FORM OF FUNCTION HERE...
  2444.     GOTO 300
  2445. 220    CONTINUE
  2446.     LNOUT(LO)=LNIN(LI)
  2447.     LO=LO+1
  2448.     LI=LI+1
  2449. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  2450. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  2451.     LO=MIN0(LO,110)
  2452.     DO 400 N=LO,110
  2453. 400    LNOUT(N)=0
  2454.     DO 1 N=111,128
  2455. 1    LNOUT(N)=LNIN(N)
  2456. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  2457.     RETURN
  2458.     END
  2459. c -h- cmdmun.for    Fri Aug 22 13:00:17 1986    
  2460.     SUBROUTINE CMDMUN(LINE)
  2461. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  2462. C ALL RIGHTS RESERVED
  2463. ccc
  2464. ccc junk VT100 escape sequence parsing except for arrow keys and
  2465. ccc PF2 since it's mostly not useful in MSDOS anyway.
  2466. ccc
  2467.     CHARACTER*1 LINE(120),LC,LINBUF(120),CW(120)
  2468. C    InTeGer*4 IOLVL,IGOLD
  2469.     EXTERNAL INDX
  2470. C    COMMON/IOLVL/IOLVL,IGOLD
  2471.     InTeGer*4 RRWACT,RCLACT
  2472. C    COMMON/RCLACT/RRWACT,RCLACT
  2473.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2474.      1  IDOL7,IDOL8
  2475. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2476. C     1  IDOL7,IDOL8
  2477.     Logical LEXIST
  2478.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2479. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2480.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2481. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2482. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2483. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2484.     InTeGer*4 KLVL
  2485. C    COMMON/KLVL/KLVL
  2486.     InTeGer*4 IOLVL,IGOLD
  2487. C    COMMON/IOLVL/IOLVL
  2488. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2489. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2490.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2491.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2492.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  2493.      3  k3dfg,kcdelt,krdelt,kpag
  2494. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2495. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2496. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2497. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2498. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2499.     Integer*4 FH
  2500.     Common/CONSFH/FH
  2501.     Integer Initd,UseDK,UseDF
  2502.     Data Initd/0/
  2503. c Assume compilation with -h so this stays around
  2504.     If(Initd.ne.0)Goto 2408
  2505.     Initd=1
  2506.     UseDF=0
  2507.     UseDK=0
  2508. c Before inserting the DK: part, check that dk:AKA.CMD can be found.
  2509.     Inquire(File='AKA.CMD',Exist=Lexist)
  2510.     If(Lexist)UseDF=1
  2511.     If(LExist)goto 2408
  2512. C Inquire on login directory first; if file not there THEN look in DK:
  2513. c This allows one to avoid a system requestor for device DK
  2514.     Inquire(File='DK:AKA.CMD',EXIST=LEXIST)
  2515.     If(Lexist)UseDF=1
  2516.     IF(Lexist)UseDK=1
  2517. c Usedk = 1 if stuff is seen in dk:
  2518. c usedf = 1 if stuff found in default OR dk:
  2519. 2408    Continue
  2520.     ITERX=0
  2521. C ALLOW RESCAN OF READ-IN COMMANDS UP TO 10 TIMES.
  2522. 6501    CONTINUE
  2523.     ITERX=ITERX+1
  2524.     IF(ITERX.GT.10)RETURN
  2525.     LI=1
  2526. C ALLOW ARROWS OR OTHER SIMILAR KEYS TO BE RECOGNIZED
  2527.     LL=ICHAR(LINE(LI))
  2528. C ALLOW ! OR ESCAPE TO BE LEADIN FOR ESCAPE SEQUENCES
  2529.     IF(LL.EQ.155.OR.LL.EQ.33.OR.LL.EQ.27)GOTO 1000
  2530. C ALLOW % SPECIAL TREATMENT
  2531.     IF(ICHAR(LINE(1)).EQ.37)GOTO 7000
  2532.     IF(LINE(1).EQ.'^')IGOLD=IGOLD+1
  2533.     IF(LINE(1).EQ.'^')GOTO 7223
  2534. C IF WE SEE , COULB BE THAT ESC GOT EATEN BY VMS...
  2535.     IF(LINE(LI).EQ.'[')GOTO 1000
  2536. C CONVERT LOWER TO UPPER CASE
  2537.     NMX=120
  2538.     DO 41 N=1,120
  2539. C CHECK FOR DOUBLE QUOTE (34 DECIMAL). LEAVE L.C. IF SO
  2540.     NNN=ICHAR(LINE(N))
  2541.     IF(NNN.EQ.34)NMX=2
  2542. C IF WE SEE " CHARACTER THEN ONLY CONVERT 1ST 2 CHARACTERS TO U.C.
  2543. 41    CONTINUE
  2544.     JFED=0
  2545.     DO 1 N=1,NMX
  2546.     LL=ICHAR(LINE(N))
  2547.     IF(LL.GT.96.AND.LL.LT.123)LL=LL-32
  2548.     LINE(N)=CHAR(LL)
  2549.     IF(LINE(N).EQ.'_'.AND.LINE(N+1).EQ.'_')JFED=N
  2550. 1    CONTINUE
  2551.     IF(JFED.LE.0)GOTO 520
  2552. C IF __ SEEN (2 UNDERSCORES IN A ROW), CALL FRMEDT AFTER REMOVING THE __ FROM
  2553. C THE COMMAND LINE.
  2554.     DO 521 KKK=JFED,118
  2555.     LINE(KKK)=LINE(KKK+2)
  2556. 521    CONTINUE
  2557.     LINE(119)=Char(0)
  2558.     LINE(120)=Char(0)
  2559.     KKK=110
  2560.     CALL FRMEDT(LINE,KKK)
  2561. 520    CONTINUE
  2562.     IF(LINE(1).NE.'M')GOTO 2000
  2563. C    IF(LINE(1).NE.'M')RETURN
  2564.     LI=2
  2565.     GOTO 1000
  2566. 1000    CONTINUE
  2567. C HANDLE ESCAPE SEQUENCES
  2568. C ENCODE VT100 SEQUENCES HERE. MUST MODIFY FOR OTHERS.
  2569. C IF VMS PASSES 2 ESCS, PASS 1ST, TEST SECOND.
  2570. C NOTE CURSOR UP,DOWN, RIGHT, LEFT ARE CODED AS ESC A,B,C, OR D
  2571. C WITH POSSIBLE CRUFT BETW ESC AND THE LETTER.
  2572.     LL=ICHAR(LINE(LI+1))
  2573.     IF(LL.EQ.155.OR.LL.EQ.27)LI=LI+1
  2574.     LC=ICHAR(LINE(LI+1))
  2575.     IF(LC.EQ.'['.OR.LC.EQ.'O')LC=ICHAR(LINE(LI+2))
  2576.     IF(LC.NE.'?'.AND.LC.NE.'Q')GOTO 10
  2577. C MAKE PF2 MEAN HELP, JUST LIKE EDT
  2578. C FIX UP AMIGA HELP KEY ALSO TO MEAN HELP...
  2579.     LINE(LI)=CHAR(72)
  2580. C 72 = ASCII FOR 'H'
  2581.     LGGG=IGOLD+8
  2582.     IF(IGOLD.LE.0)GOTO 488
  2583.     LINE(LI+1)=CHAR((LGGG/10)+48)
  2584.     LINE(LI+2)=CHAR(MOD(LGGG,10)+48)
  2585. 488    CONTINUE
  2586. C    RETURN
  2587.     GOTO 2000
  2588. 10    CONTINUE
  2589. C HANDLE AUX KEYPAD KEYS AS INDIRECTS (FOR NOW)
  2590. C MAP ENTER KEY INTO AUX KEYPAD RANGE
  2591.     IF(LC.EQ.'M')LC='o'
  2592.     IF(LC.GE.'l'.AND.LC.LE.'y')GOTO 2650
  2593.     IF(LC.GE.'P'.AND.LC.LE.'S')GOTO 2100
  2594. C HANDLE INDIRECT CALLS AT 2100 FOR PF1 THRU PF4 IF AANY
  2595.     LL=ICHAR(LC)
  2596.     IF(LL.GE.48.AND.LL.LE.63)GOTO 2640
  2597.     LL=LL-65
  2598. C SUBTRACT ASCII A
  2599.     IF (LL.LT.0.OR.LL.GT.3)GOTO 2000
  2600. C ARROW KEYS HERE. ADJUST AND PASS THEM TO REST OF PROGRAM
  2601.     LK=LL
  2602.     IF(LL.EQ.3)LK=2
  2603.     IF(LL.EQ.2)LK=3
  2604.     LK=LK+49
  2605. C ADJUST FOR ASCII VALUE
  2606.     LINE(LI)=CHAR(LK)
  2607. C STASH NEW CELL IN.
  2608. C DON'T DISTURB GOLD STATUS ON MOTION OR ON HELP. ONLY ON INDIRECT
  2609. C COMMAND FILES.
  2610.     RETURN
  2611. C    GOTO 2000
  2612. 2640    CONTINUE
  2613. C AMIGA FUNCTION KEYS
  2614.     LL=LL-48+ICHAR('l')
  2615.     LC=CHAR(LL)
  2616. c Fix up as though VT100 function chars and go on
  2617. 2650    CONTINUE
  2618.     LL=ICHAR(LC)
  2619.     LL=LL-ICHAR('l')+ICHAR('A')
  2620. C MAPPING IS:
  2621. C  KEY    CHAR    AKx.CMD  x=
  2622. C  0    p    E
  2623. c  1    q    F
  2624. C  2    r    G
  2625. c  3    s    H
  2626. c  4    t       I
  2627. c  5    u    J
  2628. c  6    v    K
  2629. c  7    w    L
  2630. c  8    x    M
  2631. c  9    y    N
  2632. c  ,    l    A
  2633. c  -    m    B
  2634. c  .    n    C
  2635. c ENTER o    D
  2636.     LC=CHAR(LL)
  2637.     LINE(1)=CHAR(64)
  2638. C 64 IS ASCII @ CHARACTER
  2639.     IVL=0
  2640. C INCLUDE "DK:" IN STRING
  2641. c
  2642.     If(UseDF.eq.0) Goto 7223
  2643.     If(UseDK.eq.0) Goto 2099
  2644.     LINE(2)='D'
  2645.     LINE(3)='K'
  2646.     LINE(4)=':'
  2647.     IVL=3
  2648. 2099    Continue
  2649.     LINE(2+IVL)='A'
  2650.     LINE(3+IVL)='K'
  2651.     GOTO 2600
  2652. 2100    CONTINUE
  2653. C GENERATE INDIRECT FILE CALLS FROM PF1, PF3, PF4 KEYS IF ANY
  2654. C (THESE GIVE LETTERS P, R, OR S)
  2655.     LINE(1)=CHAR(64)
  2656.     IVL=0
  2657.     If(UseDF.eq.0) Goto 7223
  2658.     If(UseDK.eq.0) Goto 2098
  2659.     LINE(2)='D'
  2660.     LINE(3)='K'
  2661.     LINE(4)=':'
  2662.     IVL=3
  2663. 2098    Continue
  2664.     LINE(2+IVL)='K'
  2665.     LINE(3+IVL)='Y'
  2666. 2600    CONTINUE
  2667.     LINE(4+IVL)=LC
  2668.     IF(IGOLD.LE.0)GOTO 7202
  2669. C GOLD ADDS EXTRA A,B,C,D,E,... ETC. AFTER FILENAME
  2670.     LINE(5+IVL)=CHAR(64+IGOLD)
  2671.     IVL=IVL+1
  2672. C ADD EXTRA LETTER FOR GOLDED COMMANDS
  2673. 7202    CONTINUE
  2674.     LINE(5+IVL)='.'
  2675.     LINE(6+IVL)='C'
  2676.     LINE(7+IVL)='M'
  2677.     LINE(8+IVL)='D'
  2678.     LINE(9+IVL)=0
  2679. C GENERATE @KYP, @KYR, OR @KYS COMMAND ON PF1, PF3, PF4
  2680. 2000    CONTINUE
  2681.     IGOLD=0
  2682.     RETURN
  2683. 7000    CONTINUE
  2684. C PROCESS %%% FORMS
  2685.     I1=INDX(LINE(2),37)
  2686. C IF I1 IS 1, THEN WE JUST HAVE %% AND THERE'S NOTHING TO DUMP TO
  2687. C THE SCREEN. OTHERWISE DUMP IT OUT HERE..
  2688.     I1=I1+1
  2689.     IF(I1.LE.2.OR.I1.GT.80)GOTO 7002
  2690.     II1=I1-1
  2691.     IV=II1-1
  2692.     CALL SWRT(LINE(2),IV)
  2693. 7301    FORMAT(80A1,60A1)
  2694. 7002    CONTINUE
  2695.     IF(I1.GT.80)RETURN
  2696. C COPY WHATEVER NEEDS TO BE COPIED TO LINBUF
  2697.     DO 7003 II=1,80
  2698. 7003    LINBUF(II)=0
  2699.     I2=INDX(LINE(I1+1),37)
  2700.     IF(I2.GT.80)RETURN
  2701.     I2=I2+I1
  2702.     I1=I1+1
  2703.     II2=I2-1
  2704.     II=0
  2705.     IF(II2.LT.I1)GOTO 7540
  2706.     DO 7004 LL=I1,II2
  2707.     II=II+1
  2708. 7004    LINBUF(II)=LINE(LL)
  2709. 7540    CONTINUE
  2710.     IF(I2.GT.80)RETURN
  2711. C IF LINE(I2+1) HAS & THEN CLOSE FILE RIGHT HERE AND BUG OFF
  2712.     IF(LINE(I2+1).NE.'&')GOTO 8005
  2713.     CLOSE (IOLVL)
  2714.     IOLVL=11
  2715.     LINE(I2+1)='\'
  2716. 8005    CONTINUE
  2717. C SEE IF LINE(I2+1) CONTAINS A ?
  2718.     IF(LINE(I2+1).NE.'?'.AND.LINE(I2+1).NE.'\')GOTO 7005
  2719. C HAVE TO READ IN USER'S LINE HERE... READ OFF UNIT 5 ALWAYS...
  2720.     LX=II+1
  2721. c    rewind 11
  2722. c    If(FH.NE.0)goto 9201
  2723. c    READ(11,7301,END=7035,ERR=7035)(LINBUF(II),II=LX,120)
  2724. c    rewind 11
  2725. c    Goto 9202
  2726. c9201    Continue
  2727. c read in main window
  2728.     Call Getttl(CW)
  2729.     If(ichar(cw(1)).eq.26.or.
  2730.      1  ichar(cw(1)).eq.28)goto 7035
  2731. c filter so funny chars are treated as eof... ctl Z or ctl \ are eof.
  2732.     KK=1
  2733. c copy to Linbuf array (as much as fits, anyway
  2734.     Do 9203 II=LX,120
  2735.     Linbuf(II)=CW(KK)
  2736.     KK=KK+1
  2737. 9203    Continue
  2738. c9202    Continue
  2739. c For AMIGA we use lun 11 for console, both input and output,
  2740. c for all commands except normal sheet operation (e.g. help etc.)
  2741. C NOW SEE IF LINBUF(LX) IS EITHER A \ CHAR OR ANY CONTROL CHARACTER
  2742.     LC=LINBUF(LX)
  2743.     IF(LINE(I2+1).EQ.'\'.OR.LINE(I2+1).EQ.'!')GOTO 7005
  2744.     IF(IOLVL.EQ.11)GOTO 7005
  2745. C IF WE SEE ANYTHING EXCEPT A CONTROL CHAR OR \, REWIND THE FILE...
  2746. C THIS ALLOWS US TO HAVE A SORT OF "ENTER MODE" AND A "COMMAND MODE"
  2747. C A LA SUPERCALC ETC.
  2748.     IF(LC.NE.'\'.AND.LC.GT.CHAR(32))REWIND IOLVL
  2749. C COMMENT OUT ANY TERMINAL COMMAND
  2750.     IF(LC.EQ.'\'.OR.LC.EQ.'!'.OR.LC.LE.CHAR(32))LINBUF(1)='*'
  2751.     GOTO 7005
  2752. 7035    CONTINUE
  2753. C RECOVER AFTER CTL-Z ON EXPECTED INPUT.
  2754. C    REWIND 5
  2755.     LINBUF(1)='*'
  2756.     CLOSE (IOLVL)
  2757. c    IF(IOLVL.EQ.11)OPEN(11,FILE='CON:40/150/300/40/Analy Command')
  2758.     IOLVL=11
  2759. 7005    CONTINUE
  2760.     DO 7006 II=1,120
  2761. 7006    LINE(II)=LINBUF(II)
  2762.     GOTO 6501
  2763. C ALLOW RESCAN OF COMMAND LINE AFTER READ-IN.
  2764. C    RETURN
  2765. C RETURN AFTER BUMPING IGOLD. COMMENT OUT CMD
  2766. 7223    CONTINUE
  2767.     LINE(1)='*'
  2768.     RETURN
  2769.     END
  2770. c -h- cmnd.f40    Fri Aug 22 13:00:17 1986    
  2771.     SUBROUTINE CMND(RETCD)
  2772. C COPYRIGHT (C) 1983 GLENN EVERHART
  2773. C ALL RIGHTS RESERVED
  2774. C 60=MAX REAL ROWS
  2775. C 301=MAX REAL COLS
  2776. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  2777. C VBLS AND TYPE DIMENSIONED 60,301
  2778. C   ***************************************************
  2779. C   *                                                 *
  2780. C   *         SUBROUTINE  CMND                        *
  2781. C   *                                                 *
  2782. C   ***************************************************
  2783. C
  2784. C
  2785. C  UPON ENTRANCE, NONBLK POINT TO THE "*" IN LINE
  2786. C  INDICATING A COMMAND.  THIS ROUTINE DETERMINES WHICH COMMAND
  2787. C  IS DESIRED AND CALLS THE APPROPRIATE SUBROUTINE.
  2788. C
  2789. C  RETCD:
  2790. C  1=NORMAL
  2791. C  2=BYPASS NEXT READ BECAUSE READ COMMAND HAS BEEN EXECUTED
  2792. C     TO CHANGE LINE(80)
  2793. C  3=ERROR, SO GO TO 1000 TO SET LEVEL=1
  2794. C
  2795. C
  2796. C MODIFY CLASSES: M1
  2797. C
  2798.  
  2799. C
  2800. C   CMND CALLS
  2801. C
  2802. C  AT      TO PROCESS A FILE OF CALC COMMANDS
  2803. C  BASCNG  TO CHANGE THE DEFAULT BASE FOR CONSTANTS
  2804. C  CLOSE   CLOSE FILE OF CALC COMMANDS
  2805. C  DECLR   DECLARE VAIABLES TO BE A CERTAIN DATA TYPE
  2806. C  ERRMSG  PRINTS ERROR MESSAGES
  2807. C  EXIT    RETURN TO OPERATING SYSTEM
  2808. C  GETNNB  GETS NEXT NON-BLANK FROM LINE(80)
  2809. C  STRCMP  LOOKS FOR A SPECIFIED STRING IN LINE(80)
  2810. C  ZERO    ZEROES ALL VARIABLES
  2811. C  ZNEG    TO SEE IF A VARIABLE HAS POSITIVE VALUE
  2812. C
  2813. C
  2814. C
  2815. C  CMND IS CALLED BY CALC WHO HAS IDENTIFIED THE '*'
  2816. C  INDICATING A COMMAND IS DESIRED.
  2817. C
  2818. C
  2819. C
  2820. C
  2821. C   VARIABLE      USE
  2822. C
  2823. C
  2824. C  CCHAR      TEMPORARILY HOLDS A SINGLE CHARACTER.
  2825. C  DIGITS    HOLDS ASCII REPRESENTATION OF DIGITS.
  2826. C  I         TEMPORARY INDEX.
  2827. C  ID        ARGUMENT FOR SUBROUTINE DECLR. INDICATES
  2828. C            A PARTICULAR DATA TYPE.
  2829. C  IPT       POINTER FOR LINE(80).
  2830. C  ITCNTV    0 IF NO ITERATION. IF POSITIVE, INDEX
  2831. C            OF VARIABLE USED TO CONTROL ITERATION ON THAT LEVEL.
  2832. C  KIND(15)  HOLDS FIRST LETTER OF ALL LEGAL COMMANDS.
  2833. C  LEVEL     HOLDS LOGICAL I/O UNIT WHERE NEXT COMMAND COMES FROM.
  2834. C  LINE(80)  HOLDS COMMAND LINE.
  2835. C  NONBLK    POINTER FOR LINE(80).
  2836. C  RETCD     HOLDS RETURN CODE.
  2837. C  RETCD2    HOLDS RETURN CODE.
  2838. C  VIEWSW    VIEW SWITCH:
  2839. C            0 = OFF
  2840. C            1 = DISPLAY COMMAND LINES
  2841. C            2 = DISPLAY VALUE OF EXPRESSIONS
  2842. C            3 = DISPLAY ALL
  2843. C
  2844. C
  2845. C
  2846. C    SUBROUTINE CMND(RETCD)
  2847. C
  2848. C
  2849. C    EXTERNAL INDX
  2850.     InTeGer*4 LEVEL,NONBLK,LEND
  2851.     InTeGer*4  RETCD,RETCD2,VIEWSW,BASED
  2852. C    InTeGer*4 IOLVL
  2853. C    COMMON/IOLVL/IOLVL
  2854.     InTeGer*4 ZNEG,ITCNTV(6)
  2855. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2856. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2857.     InTeGer*4 RRWACT,RCLACT
  2858. C    COMMON/RCLACT/RRWACT,RCLACT
  2859.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2860.      1  IDOL7,IDOL8
  2861. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2862. C     1  IDOL7,IDOL8
  2863.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2864. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2865.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2866. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2867. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2868. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2869.     InTeGer*4 KLVL
  2870. C    COMMON/KLVL/KLVL
  2871.     InTeGer*4 IOLVL,IGOLD
  2872. C    COMMON/IOLVL/IOLVL
  2873. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2874. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2875.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2876.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2877.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  2878.      3  k3dfg,kcdelt,krdelt,kpag
  2879. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2880. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2881. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2882.     Character*1 WRK(130)
  2883.     CHARACTER*1 WRKX(130),WRK2X(130)
  2884.     CHARACTER*1 WRK2(128)
  2885.     CHARACTER*35 CWRK,CWRKX,CWRK2
  2886.     CHARACTER*11 CWRK2B
  2887.     Character*1 wrk2b(11)
  2888.     EQUIVALENCE(CWRK2B(1:1),WRK2(1),wrk2b(1))
  2889.     EQUIVALENCE(CWRK2(1:1),WRK2(1))
  2890.     EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
  2891. C    EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
  2892. C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
  2893. c    EQUIVALENCE(WRK(1),WRKX(1))
  2894.     EQUIVALENCE(WRK2(1),WRK2X(1))
  2895.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  2896.     InTeGer*4 TYPE(1,1),VLEN(9)
  2897.     REAL*8 XAC,XVBLS(1,1)
  2898.     INTEGER*4 JVBLS(2,1,1)
  2899.     EQUIVALENCE(XAC,AVBLS(1,27))
  2900.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  2901.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  2902.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  2903.     CHARACTER*1 FVLD(1,1)
  2904.     COMMON/FVLDC/FVLD
  2905. C
  2906.     CHARACTER*1  LINE(80),KIND(23),ASCII(4),DEC(6),HEX(2),INT(6),
  2907.      ;  M10(2),M8(1),M16(2),OCTAL(4),REAL(3),CCHAR
  2908.     CHARACTER*1 DIGITS(16,3)
  2909. C
  2910.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  2911.     COMMON /ITERA/ITCNTV
  2912.     COMMON /DIGV/ DIGITS
  2913.     character*127 c11wrk
  2914. C
  2915.     DATA KIND
  2916.      1/'@','A','B','C','D','E','H','I','M','N','O','R','S','V','Z'
  2917.      2,'P','W','G','Q','F','J','X','U'/
  2918. C NOTE PWGQFJX ADDED BY GCE FOR PORTACALC INTERFACE.
  2919. C  FREE: K,U,Y, + SPECIAL CHARACTERS (LIKE .,;'"#$%^, ETC.)
  2920.     DATA  ASCII/'S','C','I','I'/,  DEC/'E','C','I','M','A','L'/
  2921.     DATA  HEX/'E','X'/, INT/'N','T','E','G','E','R'/
  2922.     DATA  M10/'1','0'/,  M8/'8'/
  2923.     DATA  M16/'1','6'/
  2924.     DATA  OCTAL/'C','T','A','L'/
  2925.     DATA  REAL/'E','A','L'/
  2926. C    DATA WRKX/130*0/,WRK2X/130*0/
  2927. C
  2928. C
  2929. C
  2930. C PICK UP NON-BLANK CHARACTER AFTER '*'
  2931.     RETCD=1
  2932.     CALL GETNNB(IPT,RETCD2)
  2933.     GOTO(2,4),RETCD2
  2934.     STOP 2
  2935. 2    NONBLK=IPT
  2936. C NONBLK POINTS TO 1ST NONBLANK CHARACTER AFTER *
  2937. C
  2938.     DO 3 I=1,23
  2939.     IF (LINE(NONBLK).EQ.KIND(I)) GOTO 6
  2940. 3    CONTINUE
  2941. C
  2942. C
  2943. C UNIDENTIFIED COMMAND
  2944. 4    GOTO 995
  2945. C
  2946. C
  2947. C
  2948. C GO TO DIFFERENT SECTIONS ON THE BASIS OF THE FIRST CHARACTER
  2949. C OF THE COMMAND.
  2950. 6    GOTO (10,20,30,1000,40,50,60,70,80,90,100,110,50,
  2951.      1  130,140,210,220,250,290,330,360,480,780),I
  2952.     STOP 6
  2953. C
  2954. C
  2955. C
  2956. C
  2957. C **************************************************
  2958. C *****    *@  INDIRECT COMMAND PROCESSING    ******
  2959. C **************************************************
  2960. 10    CALL AT(RETCD)
  2961.     GOTO (1000,999),RETCD
  2962.     STOP 10
  2963. C
  2964. C
  2965. C
  2966. C
  2967. C **************************************************
  2968. C ******      *A     DECLARE TYPE ASCII       ******
  2969. C **************************************************
  2970. 20    CALL STRCMP (ASCII,4,RETCD2)
  2971.     ID=1
  2972.     GOTO (200,995),RETCD2
  2973.     STOP 20
  2974. C
  2975. C
  2976. C
  2977. C
  2978. C **************************************************
  2979. C ******       *B      BASE DEFAULT          *******
  2980. C **************************************************
  2981. 30    CONTINUE
  2982.     CALL BASCNG(RETCD2)
  2983.     write(c11wrk,34)based
  2984.     c11wrk(20:20)=char(13)
  2985.     c11wrk(21:21)=char(10)
  2986.     IF(VIEWSW.NE.0)call vwrt(c11wrk,21)
  2987. 34    FORMAT(' DEFAULT BASE IS ',I2)
  2988.     GO TO (1000,999),RETCD2
  2989.     STOP 30
  2990. C
  2991. C
  2992. C
  2993. C
  2994. C ********************************************************
  2995. C **   *C   COMMENT, JUST RETURN (VIA STATEMENT 1000)   **
  2996. C ********************************************************
  2997. C
  2998. C
  2999. C
  3000. C **************************************************
  3001. C *******     *D     DECLARE TYPE DECIMAL    *******
  3002. C **************************************************
  3003. 40    CALL STRCMP(DEC,6,RETCD2)
  3004.     ID=2
  3005.     GOTO (200,995),RETCD2
  3006.     STOP 40
  3007. C
  3008. C
  3009. C **************************************************
  3010. C **********          *E   EXIT             ********
  3011. C **************************************************
  3012. 50    CONTINUE
  3013. C SET RETCD=4 ON EXIT IF EXIT COMMAND, SO CALC RETURNS TO ITS CALLER.
  3014.     IF (LEVEL.EQ.1) RETCD=4
  3015.     IF (LEVEL.EQ.1) RETURN
  3016. C    IF (LEVEL.EQ.1) CALL EXIT
  3017.     IF(ITCNTV(LEVEL).EQ.0)GOTO 55
  3018.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
  3019. C ITERATION VARIABLE IS POSITIVE SO EXECUTE FILE AGAIN
  3020.     REWIND LEVEL
  3021.     GO TO 1000
  3022. C
  3023. C NOTE THAT WHEN EXITING A LEVEL THAT WAS ITERATED, ITCNTV
  3024. C IS NOT SET TO ZERO. THIS REQUIRES THAT WHEN ENTERED AT
  3025. C SUBROUTINE 'AT' AND ITERATION IS NOT DESIRED, THAT ITCNTV
  3026. C MUST BE SET TO ZERO THERE
  3027.  
  3028. 55    CLOSE(LEVEL)
  3029.     LEVEL=LEVEL-1
  3030. 59    GOTO 1000
  3031. C
  3032. C
  3033. C
  3034. C
  3035. C
  3036. C **************************************************
  3037. C * *H DECLARE VARIABLES TO BE OF TYPE HEXADECIMAL *
  3038. C **************************************************
  3039. 60    CALL STRCMP (HEX,2,RETCD2)
  3040.     ID=3
  3041.     GOTO (200,995),RETCD2
  3042.     STOP 60
  3043. C
  3044. C
  3045. C
  3046. C
  3047. C **************************************************
  3048. C * *I DECLARE VARIABLE TO BE OF TYPE INTEGER (*4) *
  3049. C **************************************************
  3050. 70    CALL STRCMP (INT,6,RETCD2)
  3051.     ID=4
  3052.     GOTO (200,995),RETCD2
  3053.     STOP 70
  3054. C
  3055. C
  3056. C **************************************************
  3057. C *  *M  DECLARE VARIABLE TO BE MULTIPLE PRECISION *
  3058. C **************************************************
  3059. 80    CALL STRCMP (M10,2,RETCD2)
  3060.     ID=5
  3061.     GOTO (200,84),RETCD2
  3062.     STOP 80
  3063. C
  3064. C
  3065. C  SEE IF MULTIPLE PRECISION IS OCTAL
  3066. 84    CALL STRCMP (M8,1,RETCD2)
  3067.     ID=6
  3068.     GOTO (200,88),RETCD2
  3069.     STOP 84
  3070. C
  3071. C
  3072. C  SEE IF MULTIPLE PRECISION HEXADECIMAL
  3073. 88    CALL STRCMP (M16,2,RETCD2)
  3074.     ID=7
  3075.     GOTO (200,995),RETCD2
  3076.     STOP 88
  3077. C
  3078. C
  3079. C
  3080. C
  3081. C ************************************************************
  3082. C **  *N SUPPRESS PRINTING OF VARIABLES WHEN VALUES CHANGE  **
  3083. C ************************************************************
  3084. 90    VIEWSW=1
  3085.     GOTO 1000
  3086. C
  3087. C
  3088. C
  3089. C
  3090. C **************************************************
  3091. C ***  *O  DECLARE VARIABLE TO BE OF TYPE OCTAL  ***
  3092. C **************************************************
  3093. 100    CALL STRCMP (OCTAL,4,RETCD2)
  3094.     ID=8
  3095.     GOTO (200,995),RETCD2
  3096.     STOP 100
  3097. C
  3098. C
  3099. C
  3100. C
  3101. C
  3102. C **************************************************
  3103. C ***********     *R ENCOUNTERED       *************
  3104. C **************************************************
  3105. C
  3106. C  *R    SEE IF A REAL DECLARATION
  3107. 110    CALL STRCMP (REAL,3,RETCD2)
  3108.     ID=9
  3109.     GOTO (200,114),RETCD2
  3110.     STOP 110
  3111. C
  3112. C
  3113. C  OTHERWISE ASSUME A READ IS REQUIRED
  3114. 114    IF (LEVEL.NE.1) GOTO 117
  3115. c    Rewind 11
  3116.     c11wrk=char(13) // char(10) // 'Calr>'
  3117.     call vwrt(c11wrk,7)
  3118. c    WRITE(11,116)
  3119. c    Rewind 11
  3120.     GOTO 118
  3121. c116    FORMAT(' CALR>',$)
  3122. 117    Continue
  3123. c    Rewind 11
  3124.     c11wrk=char(13) // char(10) // 'Calc0>'
  3125.     c11wrk(7:7)=char(48+level)
  3126.     call vwrt(c11wrk,8)
  3127. cc    WRITE (11,119) LEVEL
  3128. c    Rewind 11
  3129. 119    FORMAT (' CALC<',I1,'>',$)
  3130. 118    Continue
  3131. c    Rewind 11
  3132.     Call vget(line,80)
  3133. c    READ (11,115,END=1000,ERR=990) LINE
  3134. c    Rewind 11
  3135. 115    FORMAT (80A1)
  3136. C
  3137. C  NOTE THAT IF <CR> IS HIT AS THE ONLY INPUT, RETURN IS NORMAL
  3138. C  AND PROCESSING CONTINUES ON LEVEL (RETCD=2)
  3139.     RETCD=2
  3140.     GOTO 1000
  3141. C
  3142. C
  3143. C
  3144. C
  3145. C
  3146. C ************************************************************
  3147. C ***  *V ACTIVATE PRINTING OF VARIABLE WHEN VALUES CHANGE ***
  3148. C ************************************************************
  3149. 129    NONBLK=IPT
  3150. 130    CALL GETNNB(IPT,RETCD2)
  3151.     GO TO (129,132),RETCD2
  3152.     STOP  130
  3153. 132    CCHAR=LINE(NONBLK)
  3154.     IF(CCHAR.NE.DIGITS(10,1))GO TO 134
  3155. C
  3156. C  *VIEW 0 ENCOUNTERED
  3157.     VIEWSW=0
  3158.     GO TO 1000
  3159. 134    IF(CCHAR.NE.DIGITS(1,1))GO TO 136
  3160. C
  3161. C *VIEW 1 ENCOUNTERED
  3162.     VIEWSW=1
  3163.     GO TO 1000
  3164. 136    IF(CCHAR.NE.DIGITS(2,1))GO TO 138
  3165.     VIEWSW=2
  3166.     GO TO 1000
  3167. 138    VIEWSW=3
  3168.     GOTO 1000
  3169. C
  3170. C
  3171. C
  3172. C
  3173. C **************************************************
  3174. C **********   *Z   ZERO OUT ALL VARIABLES  ********
  3175. C **************************************************
  3176. 140    CALL ZERO
  3177.     GOTO 1000
  3178. C
  3179. C
  3180. C
  3181. C
  3182. C
  3183. C MAKE DECLARATIONS
  3184. 200    CALL DECLR(ID,RETCD2)
  3185.     GO TO(1000,999),RETCD2
  3186.     STOP 200
  3187. C
  3188. C
  3189. C
  3190. C
  3191. C
  3192. C **** ERROR PROCESSING ****
  3193. C
  3194. 990    I=27
  3195.     REWIND LEVEL
  3196.     GO TO 998
  3197. 995    I=3
  3198. 998    CALL ERRMSG(I)
  3199. 999    RETCD=3
  3200. 1000    CONTINUE
  3201.     RETURN
  3202. C
  3203. C P COMMAND - SET PLACEMENT OF PHYSICAL POSN IN SHEET
  3204. C *P WILL PROMPT FOR INPUTS OF LOCATIONS.
  3205. C
  3206. 210    CONTINUE
  3207. C
  3208.     RETCD=1
  3209.     CALL CMND2(RETCD,1)
  3210.     RETURN
  3211. C W COMMAND - WRITE % TO CURRENT PHYSICAL LOC IN SHEET. USE E32.25
  3212. C FORMAT.
  3213. C  DOES NOT PROMPT. THEREFORE, IF USED INSIDE SPREADSHEET, HAS THE
  3214. C  EFFECT OF CONVERTING CURRENT CELL'S FORMULA TO A LITERAL NUMBER
  3215. C  AND FREEZING IT THAT WAY. THEREFORE A FORMULA CONTAINING *W WILL
  3216. C  NORMALLY ONLY EXECUTE THE *W ONCE (AFTERWARDS BEING OVERWRITTEN).
  3217. C
  3218. 220    CONTINUE
  3219.     RETCD=1
  3220.     CALL CMND2(RETCD,2)
  3221. C
  3222.     RETURN
  3223. C
  3224. C *G SEEN.
  3225. C THE SYNTAX OF *G IS *G V1,V2 WHICH WILL GET VALUE OF VBLS(G1,G2)
  3226. C  AND LOAD IT INTO %. THE DIMENSIONS ARE CLAMPED TO LEGAL BOUNDS
  3227. C  AND TYPE=4 MEANS USE INTEGER, TYPE=2 CONVERTS VARIABLES TO
  3228. C  INTEGER. CALLS VARSCN TO DO THIS STUFF.
  3229. C  THIS GIVES A MEASURE OF INDIRECTION.
  3230. 250    CONTINUE
  3231.     RETCD=1
  3232. C SAY ALL'S WELL.
  3233.     CALL CMND2(RETCD,3)
  3234. C
  3235.     RETURN
  3236. C
  3237. C *Q QUERY DATABASE COMMAND
  3238. C
  3239. C
  3240. 290    CONTINUE
  3241.     RETCD=1
  3242.     CALL CMND2(RETCD,4)
  3243. C
  3244.     RETURN
  3245. C
  3246. C *F LABEL  GOTO LABEL COMMAND (CONDITIONAL)
  3247. C
  3248. C
  3249. C THE SYNTAX OF THE *F COMMAND IS :
  3250. C  *F LABEL
  3251. C  WITH THE OPERATION OF LOCATING A LINE BEGINNING WITH THE
  3252. C  STRING "*CLABEL" (SO IT IS PASSED OVER BY NORMAL CALC
  3253. C  PROCESSING). THE INPUT FILE ON IOLVL IS REWOUND AND
  3254. C  SCANNING GOES TO THE EOF OR UNTIL THE STRING IS FOUND.
  3255. C  RETCD=2 IF NO SUCH LABEL IS FOUND.
  3256. C
  3257. C  AS A FURTHER AID, IF THE % VARIABLE IS 0 OR NEGATIVE, THE
  3258. C  COMMAND IS IGNORED.
  3259. 330    CONTINUE
  3260.     RETCD=1
  3261.     CALL CMND2(RETCD,5)
  3262. C
  3263.     RETURN
  3264. C
  3265. C *J LABEL - JUST LIKE *F LABEL BUT ON CALC'S COMMAND FILES.
  3266. C I.E., FINDS A LINE STARTING WITH *CLABEL
  3267. C (NOTE IT STARTS FROM START OF FILE AND DOES THIS ONLY IF % IS POSITIVE).
  3268. C ITERATION OF COMMAND FILES REMAINS UNDER NORMAL CONTROL.
  3269. 360    CONTINUE
  3270.     RETCD=1
  3271.     CALL CMND2(RETCD,6)
  3272.     RETURN
  3273. C *X COMMAND
  3274. C  XC FILESPEC CELLNAME
  3275. C    READS FILESPEC AS A SAVED SPEADSHEET (NUMERIC OR FORMULA)
  3276. C  AND LOADS ITS VALUE INTO CURRENT CELL AND % ACCUMULATOR. DOES
  3277. C  NOT LOAD FORMULA UNLESS F SEEN. THUS 2 VARIANTS:
  3278. C   *XF FILESPEC CELLNAME    LOAD FORMULA AND VALUE
  3279. C   *XV FILESPEC CELLNAME    LOAD VALUE
  3280. C NOTE ANY CHARACTER AFTER *X THAT ISN'T "F" IS EQUIVALENT TO V FOR EASY USE.
  3281. 480    CONTINUE
  3282.     RETCD=1
  3283.     CALL CMND2(RETCD,7)
  3284.     RETURN
  3285. C *U FUNCTION ARGS
  3286. C HANDLE USER FUNCTION CALL...
  3287. 780    CONTINUE
  3288.     RETCD=1
  3289. C PASS LINE AND ARGS TO SUBROUTINE TO PARSE (EXTERNALIZE THE WORK)
  3290. C COMMON /V/ HAS DATA NEEDED FOR ARGUMENTS...
  3291.     CALL USRFCT(LINE,RETCD,WRK2)
  3292. C IF RETCD CHANGES IN USRFCT THIS ALLOWS ERROR CODES BACK.
  3293.     RETURN
  3294.     END
  3295. c -h- cmnd2.f40    Fri Aug 22 13:00:17 1986    
  3296.     SUBROUTINE CMND2(RETCD,I)
  3297. C COPYRIGHT (C) 1983 GLENN EVERHART
  3298. C ALL RIGHTS RESERVED
  3299. C
  3300. C EXTRA ROUTINES MOVED HERE FROM INSIDE CMND SO THAT THEY CAN BE OVERLAIN IN
  3301. C 256K VERSION TO GAIN A GREAT DEAL OF SPACE.
  3302.     INCLUDE APARMS.INC
  3303.     EXTERNAL INDX
  3304.     InTeGer*4 LEVEL,NONBLK,LEND
  3305.     InTeGer*4  RETCD,RETCD2,VIEWSW,BASED
  3306. C    InTeGer*4 IOLVL
  3307. C    COMMON/IOLVL/IOLVL
  3308.     InTeGer*4 ZNEG,ITCNTV(6)
  3309. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3310. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3311.     InTeGer*4 RRWACT,RCLACT
  3312. C    COMMON/RCLACT/RRWACT,RCLACT
  3313.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  3314.      1  IDOL7,IDOL8
  3315. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  3316. C     1  IDOL7,IDOL8
  3317.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  3318. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3319.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  3320. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  3321. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  3322. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  3323.     InTeGer*4 KLVL
  3324. C    COMMON/KLVL/KLVL
  3325.     InTeGer*4 IOLVL,IGOLD
  3326. C    COMMON/IOLVL/IOLVL
  3327. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  3328. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  3329.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  3330.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  3331.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  3332.      3  k3dfg,kcdelt,krdelt,kpag
  3333. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  3334. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  3335. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  3336.     CHARACTER*1 WRK2(128),LETA
  3337.     CHARACTER*35 CWRK,CWRKX,CWRK2
  3338.     CHARACTER*50 CWRK50
  3339.     EQUIVALENCE (CWRK50(1:1),CWRK(1:1))
  3340.     CHARACTER*11 CWRK2B
  3341.     Character*1 wrk2b(11)
  3342.     CHARACTER*1 WRKX(130),WRK2X(130)
  3343.     Character*1 WRK(128)
  3344.     EQUIVALENCE(CWRK2B,WRK2(1),Wrk2b(1),Cwrk2)
  3345. c    EQUIVALENCE(CWRK2,WRK2(1))
  3346.     EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
  3347. C    EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
  3348. C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
  3349. c    EQUIVALENCE(WRK(1),WRKX(1))
  3350.     EQUIVALENCE(WRK2(1),WRK2X(1))
  3351.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  3352.     InTeGer*4 TYPE(1,1),VLEN(9)
  3353.     REAL*8 XAC,XVBLS(1,1)
  3354.     INTEGER*4 JVBLS(2,1,1)
  3355.     EQUIVALENCE(XAC,AVBLS(1,27))
  3356.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  3357.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  3358.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  3359.     CHARACTER*1 FVLD(1,1)
  3360.     COMMON/FVLDC/FVLD
  3361. C
  3362.     CHARACTER*1  LINE(80),CCHAR
  3363.     CHARACTER*1 DIGITS(16,3)
  3364. C
  3365.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  3366.     COMMON /ITERA/ITCNTV
  3367.     COMMON /DIGV/ DIGITS
  3368. C I ARGUMENT SELECTS COMMAND.
  3369. C 1 = *P
  3370. C 2 = *W
  3371. C 3 = *G 
  3372. C 4 = *Q
  3373. C 5 = *F
  3374. C 6 = *G
  3375. C 7 = *X
  3376.     IF(I.NE.1)GOTO 7000
  3377. C *P COMMANDS
  3378. C IF THE COMMAND IS *P VAR THEN SET TO VARIABLE LOCATION.
  3379.     KK1=3
  3380.     KK2=20
  3381.     IF(LINE(3).EQ.'@')GOTO 217
  3382. C ONLY LOOK IN COLS 3-20. COLUMNS 1,2 ARE THE *W COMMAND.
  3383.     CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
  3384.     IF(IVLD.NE.0)GOTO 216
  3385.     GOTO 218
  3386. 217    CONTINUE
  3387. C ALLOW *W@V1,V2 TO GOTO LOCATION OF V1,V2 (COL,ROW)
  3388. C  THIS ALLOWS PROGRAMMED ACCESS TO VARIABLES.
  3389.     L1=4
  3390.     L2=60
  3391.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
  3392.     IF(IVLD1.EQ.0)GOTO 1000
  3393.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  3394.     IF(TYPE(1,1).EQ.2)GOTO 219
  3395.     CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
  3396.     LCL=JVBLS(1,1,1)
  3397.     GOTO 2200
  3398. 219    CONTINUE
  3399.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  3400.     LCL=XVBLS(1,1)
  3401. 2200    CONTINUE
  3402. C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
  3403.     L1=LSTCH+1
  3404.     L2=60
  3405. C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
  3406.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
  3407.     IF(IVLD2.EQ.0)GOTO 1000
  3408. C SEEMS LIKE OK VARIABLE... GO AHEAD
  3409.     CALL TYPGET(ID1B,ID2B,TYPE(1,1))
  3410.     CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
  3411.     LRW=JVBLS(1,1,1)
  3412.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  3413.     IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
  3414. C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
  3415.     LRW=LRW+1
  3416. C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
  3417. C CLAMPING TO MAX VALUES.
  3418.     LCL=MAX0(1,LCL)
  3419.     LRW=MAX0(1,LRW)
  3420.     LCL=MIN0(LCL,MCOLS)
  3421.     LRW=MIN0(LRW,MROWS)
  3422.     KK=LCL
  3423.     KKK=LRW
  3424.     GOTO 216
  3425. 218    CONTINUE
  3426. c    rewind 11
  3427.     IF(LEVEL.EQ.1)call Vwrt(' Set Phys loc. Column=',22)
  3428. c211    FORMAT(' SET PHYS LOC. COLUMN=')
  3429. c    rewind 11
  3430.     LLLV=LEVEL
  3431.     IF(LEVEL.EQ.1)LLLV=11
  3432.     if(lllv.ne.11)READ(LLLV,212,END=700,ERR=700)KK
  3433.     if(lllv.eq.11)call vgeti(kk)
  3434. 212    FORMAT(I7)
  3435. c    rewind 11
  3436.     IF(LEVEL.EQ.1)Call Vwrt(' Set Phys loc. Row=',19)
  3437. c213    FORMAT(' SET PHYS LOC. ROW =')
  3438. c    rewind 11
  3439.     If(lllv.ne.11)READ(LLLV,212,END=700,ERR=700)KKK
  3440.     if(lllv.eq.11)call Vgeti(kkk)
  3441. c    rewind 11
  3442.     KKK=KKK+1
  3443. 216    KK=MAX0(1,KK)
  3444.     KKK=MAX0(1,KKK)
  3445.     KK=MIN0(MCOLS,KK)
  3446.     KKK=MIN0(MROWS,KKK)
  3447. C CLAMP TO LEGAL SIZE
  3448.     PROW=KK
  3449.     PCOL=KKK
  3450. C
  3451.     RETURN
  3452. C TERMINAL READ ERROR AND END PROCESSING
  3453. 700    CONTINUE
  3454. c    IF(LEVEL.EQ.1)CLOSE(11)
  3455. c    IF(LEVEL.EQ.1)OPEN(11,FILE='CON:20/100/300/40/Analy Command')
  3456.     IF(LEVEL.NE.1)REWIND LEVEL
  3457.     IF(ITCNTV(LEVEL).EQ.0)GOTO 55
  3458.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
  3459.     RETURN
  3460. 7000    CONTINUE
  3461.     IF(I.NE.2)GOTO 7200
  3462. C *W COMMANDS
  3463. C    IRX=(PCOL-1)*60+PROW
  3464.     CALL REFLEC(PCOL,PROW,IRX)
  3465.     CALL WRKFIL(IRX,WRK,0)
  3466. C    READ(7'IRX)WRK
  3467. C GET RECORD INTO MEMORY
  3468.     IF(LINE(3).EQ.'F')GOTO 224
  3469.     WRITE(CWRK(1:35),221)XAC
  3470. C    ENCODE(35,221,WRK)XAC
  3471. C PUT VARIABLE VALUE AS STRING INTO FILE BUFFER
  3472. 221    FORMAT(D32.25)
  3473.     GOTO 225
  3474. 224    CONTINUE
  3475. C WRITE AND USE LOCAL FORMAT
  3476.     WRK2(1)='('
  3477.     DO 226 K=1,9
  3478.     WRK2(1+K)=WRK(119+K)
  3479. 226    CONTINUE
  3480.     WRK2(11)=')'
  3481.     WRITE(CWRK(1:35),WRK2B)XAC
  3482. 225    CONTINUE
  3483.     DO 222 K=36,110
  3484. 222    WRK(K)=CHAR(32)
  3485.     CALL WRKFIL(IRX,WRK,1)
  3486. C    WRITE(7'IRX)WRK
  3487.     RETURN
  3488. 7200    CONTINUE
  3489.     IF(I.NE.3)GOTO 7400
  3490. C *G COMMANDS
  3491.     L1=3
  3492.     L2=60
  3493.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
  3494.     IF(IVLD1.EQ.0)GOTO 1000
  3495.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  3496.     IF(TYPE(1,1).EQ.2)GOTO 251
  3497.     CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
  3498.     LCL=JVBLS(1,1,1)
  3499.     GOTO 252
  3500. 251    CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  3501.     LCL=XVBLS(1,1)
  3502. 252    CONTINUE
  3503. C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
  3504.     L1=LSTCH+1
  3505.     L2=60
  3506. C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
  3507.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
  3508.     IF(IVLD2.EQ.0)GOTO 1000
  3509. C SEEMS LIKE OK VARIABLE... GO AHEAD
  3510.     CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
  3511.     CALL TYPGET(ID1B,ID2B,TYPE(1,1))
  3512.     LRW=JVBLS(1,1,1)
  3513.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  3514.     IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
  3515. C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
  3516.     LRW=LRW+1
  3517. C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
  3518. C CLAMPING TO MAX VALUES.
  3519.     LCL=MAX0(1,LCL)
  3520.     LRW=MAX0(1,LRW)
  3521.     LCL=MIN0(LCL,MCOLS)
  3522.     LRW=MIN0(LRW,MROWS)
  3523. C RETURN VALUE.
  3524.     CALL TYPGET(LCL,LRW,TYPE(1,1))
  3525.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(LCL,LRW,XAC)
  3526.     IF(TYPE(1,1).NE.2)CALL JVBLGT(1,LCL,LRW,JVBLS(1,1,1))
  3527.     IF(TYPE(1,1).NE.2)XAC=JVBLS(1,1,1)
  3528. C USE IMPLICIT CONVERSION FROM FORTRAN HERE. NOTE WE RETURN WITH
  3529. C THE LOOKED UP VALUE IN XAC.
  3530.     RETURN
  3531. 7400    CONTINUE
  3532.     IF(I.NE.4)GOTO 7600
  3533. C *Q COMMANDS
  3534. C *Q QUERY DATABASE COMMAND
  3535. C
  3536. C
  3537. C THIS COMMAND IS DESIGNED TO PERMIT CALC TO ACCESS SEQUENTIAL (FOR NOW)
  3538. C FILES AND PULL IN VALUES. ARRAY WRK IS USED TO HOLD THE RECORDS AND
  3539. C MAY DISPLAY WHATEVER IS DESIRED.
  3540. C
  3541. C OPERATION IS AS FOLLOWS:
  3542. C
  3543. C *QW/F filespec ?KEYSTRING? <cc>
  3544. C WHERE THE W/F FLAG MEANS WRITE TO FORMULA AT CURRENT LOC (MAYBE MODIFIED
  3545. C EARLIER BY THE *P COMMAND) AND F FLAG MEANS RETURN % AS VALUE OBTAINED BY
  3546. C ATTEMPTING A DECODE ON THE FILE LINE BETWEEN DELIMITER CHARACTERS
  3547. C cc GIVEN INSIDE  CHARACTERS. FILE IS ASSUMED TO START WITH
  3548. C "KEYSTRING" WHERE ANY CHARACTER IS A MATCH EXACTLY EXCEPT THAT
  3549. C THE _ CHARACTER INDICATES A WILDCARD.
  3550. C SPECIAL CASES:
  3551. C  IF ` IS 1ST CHAR OF KEYSTRING, RECORDS MUST HAVE KEYSTRING STARTING
  3552. C AT COL 1 (EXCLUDING THE `)
  3553. C  IF <CC> STRING HAS ` AS 1ST CHARACTER, THEN IT IS OF FORM
  3554. C <`NM> WHERE N=ASCII CODE FOR COLUMN WANTED + 32 AND M = ASCII CODE
  3555. C   FOR LENGTH DESIRED + 32
  3556. C  THIS ALLOWS POSITIONAL RETRIEVAL (THOUGH PAINFULLY)
  3557. C
  3558. C A SECOND KEYSTRING MAY BE ENTERED INSIDE A SECOND PAIR OF ? CHARACTERS TOO.
  3559. C  THE SEARCH WILL SEEK THE KEYS ANYWHERE IN THE RECORDS READ, UP TO 128
  3560. C  CHARACTERS LONG EACH.
  3561. C SECOND KEYSTRING MAY NOT BE ANCHORED TO START OF LINE.
  3562. C  AS AN ADDED ATTRACTION:
  3563. C   *QFK  OR *QFN  WON'T CLOSE LUN 4 AT END. IN ADDITION *QFN WON'T
  3564. C  CLOSE IT AT START EITHER ALLOWING SEQUENTIAL RETRIEVALS OUT OF
  3565. C  DATA FILES. DITTO *QW VARIANTS.
  3566. C    IRX=(PCOL-1)*60+PROW
  3567.     CALL REFLEC(PCOL,PROW,IRX)
  3568. C    IF(LINE(3).EQ.'W')READ(7'IRX)WRK
  3569.     IF(LINE(3).EQ.'W')CALL WRKFIL(IRX,WRK,0)
  3570.     IF(LINE(3).NE.'W'.AND.LINE(3).NE.'F')RETURN
  3571.     IL=INDX(LINE,32)
  3572.     IF(IL.GT.40)GOTO 299
  3573.     IL2=INDX(LINE(IL+1),32)
  3574.     IF(IL2.GT.38)GOTO 299
  3575. C ENSURE LUN 4 AVAILABLE
  3576.     IF(LINE(4).NE.'C'.AND.LINE(4).NE.'N')CLOSE(4)
  3577.     LINE(IL2+IL)=CHAR(0)
  3578.     IF(LINE(4).NE.'N'.AND.LINE(4).NE.'C')
  3579.      1   CALL RASSIG(4,LINE(IL+1))
  3580. C THIS MAKES LUN 4 BE THE ONE WE WANT
  3581.     LINE(IL2+IL)=CHAR(32)
  3582.     KKK=ICHAR('?')
  3583.     IQ1=INDX(LINE,KKK)
  3584. C LOCATE THE KEY
  3585.     IF(IQ1.GE.70)GOTO 299
  3586.     KKK=ICHAR('?')
  3587.     IQ2=INDX(LINE(IQ1+1),KKK)
  3588.     IF(IQ2.GE.72)GOTO 299
  3589. C NOW KNOW KEY IS IQ2-1 LONG, STARTS AT IQ1+1
  3590. C
  3591. C ALLOW DOUBLE KEYS IF ANOTHER ?? PAIR IS SEEN.
  3592.     KEYS2=0
  3593.     KKK=ICHAR('?')
  3594.     IQ3=INDX(LINE(IQ1+IQ2+1),KKK)
  3595.     IF(IQ3.GT.3)GOTO 297
  3596. C WELL, THERE'S A 2ND STRING THERE MAYBE.
  3597.     IQ4=INDX(LINE(IQ3+IQ1+IQ2+1),KKK)
  3598.     IF(IQ4.GT.30)GOTO 297
  3599.     IF(IQ4.EQ.1)GOTO 297
  3600.     KEYS2=1
  3601. C FLAG WE HAVE A SECOND KEY. SOMETHING'S THERE.
  3602.     LCL=IQ3+IQ2+IQ1+1
  3603.     LRW=LCL+IQ4-1
  3604. 297    READ(4,332,END=299,ERR=299)WRK2
  3605.     IQQ=IQ2-1
  3606.     IXX=128-IQ2
  3607. C COMPARE THE ENTIRE RECORD FOR THE KEY, MATCH ANYWHERE.
  3608.     IF(LINE(IQ1+1).NE.'`')GOTO 376
  3609. C IF 1ST CHAR OF KEY IS ` THEN SEARCH BEGINS AT LINE START ONLY. KEY IS
  3610. C 1 LESS.
  3611.     IQ1=1+IQ1
  3612.     IXX=1
  3613.     IQQ=IQQ-1
  3614. C ADJUST SO SEARCH IS 1 CHAR LESS.
  3615. 376    CONTINUE
  3616.     DO 350 KKK=1,IXX
  3617.     CALL SCMP(LINE(IQ1+1),WRK2(KKK),IQQ,ICOD)
  3618.     IF(ICOD.NE.0)GOTO 351
  3619. 350    CONTINUE
  3620. C DON'T JUST FALL THRU
  3621.     GOTO 353
  3622. 351    CONTINUE
  3623.     IF(KEYS2.EQ.0)GOTO 353
  3624. C CHECK SECOND KEY STRING IN RECORD IF ANY WAS ASKED FOR.
  3625. C (THAT'S ALL YOU GET. 2 KEYS MAX.)
  3626. C LINE(LCL) TO LINE(LRW) CONTAINS KEY.
  3627.     IXY=128-IQ4+1
  3628.     ICC=IQ4-1
  3629.     DO 354 KKK=1,IXY
  3630.     CALL SCMP(LINE(LCL),WRK2(KKK),ICC,ICOD)
  3631.     IF(ICOD.NE.0)GOTO 355
  3632. 354    CONTINUE
  3633. 355    CONTINUE
  3634. 353    IF(ICOD.EQ.0)GOTO 297
  3635. C HERE FOUND THE KEYED RECORD. NOW EXAMINE COMMAND LINE FOR
  3636. C SPECIAL CHARACTERS. IF NONE, JUST COPY THE FIRST CHARACTERS
  3637. C IN THE TEXT INTO EITHER THE BUFFER OR ENCODE THEM.
  3638.     KKK=ICHAR('<')
  3639.     IQ1=INDX(LINE,KKK)
  3640.     IF(IQ1.LE.0.OR.IQ1.GT.75)GOTO 296
  3641.     KKK=ICHAR('>')
  3642.     IQ2=INDX(LINE(IQ1+1),KKK)
  3643.     IF(IQ2.LE.0.OR.IQ2.GT.8)GOTO 296
  3644.     KKQ=ICHAR(LINE(IQ1+1))
  3645.     KK=INDX(WRK2,KKQ)
  3646. C MUNGE THE SEARCH SO THAT IF THE SPECIAL CHAR IS ` THEN THE NEXT 2
  3647. C CHARACTERS HAVE START AND LENGTH ENCODED AS ASCII CODE -32 DECIMAL
  3648. C WHICH ALLOWS FIELDS TO BE PLACED ANYWHERE (THOUGH SOMEWHAT PAINFULLY)
  3649.     IF(LINE(IQ1+1).EQ.'`')KK=ICHAR(LINE(IQ1+2))-32
  3650.     IF(KK.GT.125)GOTO 299
  3651. C NOTE THAT THE KEY FORM WOULD THEN GIVE
  3652. C  <`!@> FOR START COLUMN=1 AND LENGTH =32 (ASCII 64 = @ AND ASCII 33 = !)
  3653. C THIS MEANS USER HAS TO KNOW ASCII ORDER BUT AT LEAST IT'S IN MANUAL.
  3654.     IF(LINE(IQ1+1).EQ.'`')KKK=ICHAR(LINE(IQ1+3))-32
  3655.     KKQ=ICHAR(LINE(IQ1+2))
  3656.     IF(LINE(IQ1+1).NE.'`')KKK=INDX(WRK2(KK+1),KKQ)+KK
  3657.     GOTO 295
  3658. 296    CONTINUE
  3659. C DEFAULT, NO SPECIAL CHARS.
  3660.     KK=0
  3661.     KKK=110
  3662. 295    CONTINUE
  3663.     KL=KKK-KK-1
  3664.     KK=KK+1
  3665.     IF(LINE(3).NE.'W')GOTO 294
  3666.     KL=MIN0(KL,109)
  3667.     DO 293 N=1,KL
  3668.     WRK(N)=WRK2(KK)
  3669. 293    KK=KK+1
  3670.     WRK(KL+1)=0
  3671. C WRITE OUT THE RECORD'S KEY PART INTO SHEET FILE
  3672.     CALL WRKFIL(IRX,WRK,1)
  3673. C    WRITE(7'IRX)WRK
  3674.     XAC=1.
  3675.     GOTO 298
  3676. 294    CONTINUE
  3677. C FLOAT THE VALUE, RETURN IN XAC
  3678.     DO 750 N=1,35
  3679.     WRK(N)=CHAR(32)
  3680.     IF(N.LE.KL)WRK(N)=WRK2(KK-1+N)
  3681. 750    CONTINUE
  3682.     READ(CWRK(1:35),221,ERR=299)XAC
  3683. C    DECODE(KL,221,WRK2(KK),ERR=299)XAC
  3684. 298    CONTINUE
  3685. C IF IT'S A KEEP OR NEXT TYPE OPERATION, LEAVE LUN 4 OPEN.
  3686. C FIRST ONE MUST BE A KEEP (TO OPEN FILE IN THE FIRST PLACE)
  3687. C AND SUBSEQUENT OPERATIONS MAY BE A N OPERATIONS, WHICH
  3688. C WILL JUST CONTINUE SEQUENTIAL READIN OF DATA. USER HAS TO
  3689. C KEEP TRACK. NOTE RETURN VALUE IS -999999. (6 9'S) IF WE
  3690. C FAIL AND HAVE TO CLOSE FILE.
  3691.     IF(LINE(4).EQ.'K'.OR.LINE(4).EQ.'N')RETURN
  3692.     CLOSE(4)
  3693.     RETURN
  3694. 299    CONTINUE
  3695. C RETURN -999999 IF WE FAIL IN FINDING FILE.
  3696.     XAC=-999999.
  3697.     CLOSE(4)
  3698. C    COME HERE FOR NON-RECOVERABLE ERRORS IN FORMAT TOO.
  3699. C
  3700.     RETURN
  3701. 7600    CONTINUE
  3702.     IF(I.NE.5)GOTO 7800
  3703. C *F COMMANDS
  3704.     IF(XAC.LE.0)RETURN
  3705.     REWIND IOLVL
  3706.     IF(IOLVL.EQ.11)RETURN
  3707. 333    READ(IOLVL,332,END=331,ERR=331)WRK
  3708. 332    FORMAT(128A1)
  3709.     IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 333
  3710.     ISSL=2
  3711.     ISSS=2
  3712.     IF(LINE(3).EQ.' ')ISSL=3
  3713.     IF(WRK(3).EQ.' ')ISSS=3
  3714.     CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
  3715.     IF(ICODE.EQ.0)GOTO 333
  3716.     RETURN
  3717. C ERROR ENTRY WHERE WE SEE WE FAILED TO FIND LABEL.
  3718. 331    CONTINUE
  3719.     IF(IOLVL.NE.11)CLOSE(IOLVL)
  3720.     IOLVL=11
  3721.     RETCD=2
  3722. C
  3723.     RETURN
  3724. 7800    CONTINUE
  3725.     IF(I.NE.6)GOTO 8000
  3726. C *G
  3727.     IF(LEVEL.EQ.1.OR.XAC.LE.0)RETURN
  3728.     REWIND LEVEL
  3729. 363    READ(LEVEL,362,END=55,ERR=55)WRK
  3730. 362    FORMAT(128A1)
  3731.     IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 363
  3732.     ISSL=2
  3733.     ISSS=2
  3734.     IF(LINE(3).EQ.' ')ISSL=3
  3735.     IF(WRK(3).EQ.' ')ISSS=3
  3736.     CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
  3737.     IF(ICODE.EQ.0)GOTO 363
  3738. C
  3739.     RETURN
  3740. 8000    CONTINUE
  3741.     IF(I.NE.7)GOTO 8200
  3742. C *X COMMANDS
  3743. C NOW GET THE ARGS
  3744.     JFFG=0
  3745.     IF(LINE(3).EQ.'F')JFFG=1
  3746. C NOW HAVE FORMULA FLAG.
  3747.     IQ3=4
  3748. C ALLOW 1 SPACE OPTIONALLY
  3749.     IF(LINE(IQ3).EQ.' ')IQ3=5
  3750.     IQ1=INDX(LINE(IQ3),32)
  3751.     IQ1=IQ1+IQ3-1
  3752. C NULL TERMINATE FILENAME WHILE PARSING IT (DON'T LET ASSIGN SEE VBL NAME)
  3753.     LINE(IQ1)=0
  3754.     CLOSE(4)
  3755. 9770    CALL RASSIG(4,LINE(IQ3))
  3756. C REPLACE THE SPACE FOR VARSCN'S SIGHT
  3757.     LINE(IQ1)=CHAR(32)
  3758. C IQ1 NOW HAS START INDEX FOR VARSCN DESIRED... GO GET VRBL NAME.
  3759.     KK1=IQ1
  3760.     KK2=IQ1+20
  3761.     CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
  3762.     IF(IVLD.LE.0)GOTO 481
  3763. C GOT VALID VARIABLE NAME. KK,KKK ARE ROW,COL
  3764. C NOW WE KNOW HOW TO RETRIEVE THE DATA OFF FILE IN UNIT 4
  3765. C READ INTO WRK ARRAY TILL WE GET IT.
  3766.     IQ3=KK
  3767.     IQ4=KKK-1
  3768. 483    READ(4,332,END=488,ERR=488)WRK
  3769. C IGNORE TITLE
  3770. 486    CONTINUE
  3771. C NOTE WE READ IN THE NUMBER IN NUMERIC FORMAT. EASIER THAT WAY.
  3772. c    IF(JFFG.EQ.0)READ(4,484,END=488,ERR=488)IRRW,ICCL,XYVAL
  3773. c    IF(JFFG.NE.0)READ(4,489,END=488,ERR=488)IRRW,ICCL,
  3774. c     1  (WRK(IV),IV=1,110)
  3775. c484    FORMAT(1X,I5,1X,I5,1X,E50.35)
  3776. c489    FORMAT(1X,I5,1X,I5,1X,110A1)
  3777.     READ(4,484,END=488,ERR=488)LETA,IRRW,ICCL,
  3778.      1  (WRK(IV),IV=1,110)
  3779. C ALWAYS READ TEXT AS ALPHA
  3780.     READ(CWRK50(1:50),6486,ERR=5486)XYVAL
  3781. C DECODE AND STORE IN XYVAL IF POSSIBLE
  3782. 6486    FORMAT(BN,D50.35)
  3783. 5486    CONTINUE
  3784. C HACK OUT TRAILING BLANKS
  3785.     DO 5322 IV=1,110
  3786.     IVV=111-IV
  3787.     IF(ICHAR(WRK(IVV)).GT.32)GOTO 5323
  3788.     WRK(IVV)=CHAR(0)
  3789. 5322    CONTINUE
  3790. 5323    CONTINUE
  3791. C &&&&
  3792. 484    FORMAT(1A1,I5,1X,I5,1X,110A1,50A1)
  3793.     READ(4,485,END=488,ERR=488)LFVLD,(WRK(IV),IV=120,128),KKTYP
  3794. C ALLOW FLAG OF 3 FOR NUMERIC,RECALCULATE... 2 FOR NUMERIC, NO RECALC.
  3795. C 1 CONTINUES TO MEAN ALWAYS RECALCULATE.
  3796.     IF(LFVLD.LT.-1)LFVLD=-3
  3797.     IF(LFVLD.GT.1)LFVLD=3
  3798. C
  3799. 485    FORMAT(I3,1X,9A1,1X,I5)
  3800. C READS IN AN ENTRY OF SAVED SHEET. TEST IF IN OUR RANGE.
  3801.     IF(IRRW.EQ.IQ3.AND.ICCL.EQ.IQ4)GOTO 487
  3802.     GOTO 486
  3803. 487    CONTINUE
  3804. C SUCCESS. NOW FILL IN VALUE OR FORMULA.
  3805.     IF(JFFG.EQ.0)GOTO 6487
  3806. C IF READING IN FORMULA, TRY AND GET VALUE OUT OF VALUE
  3807. C RECORD
  3808.     IF(LETA.NE.'p')GOTO 6487
  3809. C OK, THIS IS A VALUE RECORD WHICH SHOULD BE IMMEDIATELY FOLLOWED
  3810. C BY A FORMULA RECORD.
  3811. C   JUST DECODE THE VALUE AND RECORD IT.
  3812. C  ... ACTUALLY IT'S ALREADY DECODED SO JUST RECORD IT.
  3813.     CALL XVBLST(PROW,PCOL,XYVAL)
  3814.     XAC=XYVAL
  3815. C GO BACK AND GET FORMULA
  3816.     GOTO 486
  3817. 6487    CONTINUE
  3818. C    IRX=(PCOL-1)*60+PROW
  3819.     CALL REFLEC(PCOL,PROW,IRX)
  3820.     WRK(118)=CHAR(15)
  3821.     WRK(119)=CHAR(LFVLD)
  3822.     CALL FVLDST(PROW,PCOL,LFVLD)
  3823. C    FVLD(PROW,PCOL)=LFVLD
  3824. C SET UP TO SAVE FORMULA.
  3825. C SAVE EITHER FORMULA OR VALUE.
  3826.     IF(JFFG.EQ.0)GOTO 4890
  3827.     CALL CA2E(WRK,WRK2)
  3828.     CALL WRKFIL(IRX,WRK2,1)
  3829.     GOTO 488
  3830. 4890    CONTINUE
  3831. C SET UP NUMBER IF HERE.
  3832.     CALL TYPSET(PROW,PCOL,KKTYP)
  3833. C    TYPE(PROW,PCOL)=KKTYP
  3834.     CALL FVLDST(PROW,PCOL,LFVLD)
  3835. C    FVLD(PROW,PCOL)=LFVLD
  3836.     CALL XVBLST(PROW,PCOL,XYVAL)
  3837. C    XVBLS(PROW,PCOL)=XYVAL
  3838.     XAC=XYVAL
  3839. 488    CONTINUE
  3840.     CLOSE(4)
  3841.     RETURN
  3842. 481    CONTINUE
  3843.     CLOSE(4)
  3844.     RETCD=2
  3845. C
  3846.     RETURN
  3847. 8200    CONTINUE
  3848. 55    CLOSE(LEVEL)
  3849.     LEVEL=LEVEL-1
  3850. 1000    CONTINUE
  3851.     RETURN
  3852.     END
  3853. c -h- contyp.for    Fri Aug 22 13:00:17 1986    
  3854.     SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
  3855. C COPYRIGHT (C) 1983 GLENN EVERHART
  3856. C ALL RIGHTS RESERVED
  3857. C 60=MAX REAL ROWS
  3858. C 301=MAX REAL COLS
  3859. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  3860. C VBLS AND TYPE DIMENSIONED 60,301
  3861. C *                                                *
  3862. C *            SUBROUTINE CONTYP                   *
  3863. C
  3864. C
  3865. C  CONVERTS CONSTANT IN STACK(I,INDXX) FROM OLDTYP TO NEWTYP
  3866. C  IF OLDTYP.EQ.NEWTYP A RETURN IS MADE IMMEDIATELY.
  3867. C  NOTE THAT TYPE(INDXX) IS NOT CHANGED BY THIS ROUTINE
  3868. C  TYPE CODES:
  3869. C
  3870. C    0    NO CHANGE
  3871. C    1    ASCII
  3872. C    2    DECIMAL
  3873. C    3    HEXADECIMAL
  3874. C    4    INTEGER
  3875. c note: multiple precision conversions diked out
  3876. C    5    M10
  3877. C    6    M8
  3878. C    7    M16
  3879. C    8    OCTAL
  3880. C    9    REAL
  3881. C
  3882. C  RETCD    MEANING
  3883. C
  3884. C    1    O.K.
  3885. C    2    ERROR
  3886. C
  3887. C
  3888. C   MODIFY CLASSES:  M3,M4,M8
  3889. C
  3890. C  CONTYP CALLS:
  3891. C
  3892. C   ERRMSG   PRINTS OUT ERROR MESSAGES
  3893. C   MULCON   CONVERTS MULTIPLE PRECISION TO MULTIPLE PRECISION
  3894. C            OF A DIFFERENT BASE
  3895. C
  3896. C
  3897. C
  3898. C  CONTYP IS CALLED BY
  3899. C
  3900. C   CALUN    CALCULATES UNARY OPERATIONS
  3901. C   CALBIN   CALCULATES BINARY OPERATIONS
  3902. C   VARIABLE     USE
  3903. C
  3904. C  BASE        HOLDS BASE OR POWERS OF THAT BASE (INTEGER*4).
  3905. C  BASVEC      HOLDS LEGAL BASES: 8,10, AND 16
  3906. C  EIGHT(8)    CHARACTER*1 ARRAY TO PICK OFF REAL*8 VALUES.
  3907. C  FOUR(4)     CHARACTER*1 ARRAY TO PICK OFF INTEGER*4 VALUES.
  3908. C  I,J,M       TEMPORARY VALUES.
  3909. C  IBASE       HOLDS BASE OF A NUMBER WHEN BASE HOLDS THE POWERS
  3910. C              OF THAT BASE.
  3911. C  IEND        HOLDS THE NUMBER OF MULTIPLE PRECISION DIGITS THAT
  3912. C              WILL BE PICKED UP WHEN CONVERTING TO INTEGER*4.
  3913. C  INDXX       POINTER TO VARIABLE BEING CONVERTED.
  3914. C  INT         HOLDS INTEGER*4 VALUES EQUIVALENCED TO VECTOR FOUR.
  3915. C  IS          TEMPORARILY HOLDS MULTIPLE PRECISION BASE 8 OR BASE
  3916. C              16 DIGITS.
  3917. C  IS2         TEMPORARILY HOLDS A DIGIT VALUE WHEN CHECKING MULTIPLE
  3918. C              PRECISION BASE 8 AND BASE 16 NUMBERS TO SEE IF THEY
  3919. C              ARE TOO LARGE TO FIT IN INTEGER*4.
  3920. C  ISGN        USED WHEN DETERMINING THE MAXIMUM NUMBER THAT CAN BE
  3921. C              HELD BY INTEGER*4. 1=POSITIVE, 2= NEGATIVE. ALSO HOLDS
  3922. C              0 OR 7 FOR BASE 8 MAXIMUM NUMBER CHECK. HOLDS 0 OR 15
  3923. C              FOR BASE 16 MAXIMUM NUMBER CHECK.
  3924.  
  3925. C  K           TEMPORARILY HOLDS INTEGER*4 VALUES.
  3926. C  NEWTYP      NEW DATA TYPE REQUESTED.
  3927. C  OLDTYP      DATA TYPE OF THE VARIABLE TO BE CONVERTED.
  3928. C  RBASE       BASE WHEN CONVERTING FROM MULTIPLE PRECISION TO REAL*8.
  3929. C  REAL        HOLDS REAL*8 VALUES. EQUIVALENCED TO ARRAY EIGHT.
  3930. C  RETCD       RETURN CODE. 1=O.K.  2=ERROR.
  3931. C  RPOWER      HOLDS POWERS OF RBASE WHEN CONVERTING FROM MULTIPLE
  3932. C              PRECISION TO REAL*8.
  3933. C  STACK(I,INDXX)  HOLDS VARIABLE TO BE CONVERTED.
  3934. C
  3935. C
  3936. C    SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
  3937. C
  3938.     REAL*8 REAL,RBASE,RPOWER,DFLOAT
  3939. C
  3940.     INTEGER*4 K,INT,BASE
  3941. C
  3942.     InTeGer*4 OLDTYP,NEWTYP,RETCD,BASVEC(3),INDXX
  3943.     InTeGer*4 MAX10(10,2)
  3944.     InTeGer*4 I,M,J
  3945.     InTeGer*4 ISGN,IS,IS2
  3946. C
  3947.     CHARACTER*1 EIGHT(8),FOUR(4)
  3948.     CHARACTER*1 STACK(8,40)
  3949. C
  3950.     EQUIVALENCE (FOUR,INT),(REAL,EIGHT)
  3951. C
  3952.     DATA BASVEC/10,8,16/
  3953.     DATA MAX10/2,1,4,7,4,8,3,6,4,7,2,1,4,7,4,8,3,6,4,8/
  3954. C
  3955. C
  3956. C  SET DEFAULT RETURN CODE
  3957.     RETCD=1
  3958.     IF(OLDTYP.GT.0)GO TO 910
  3959. C
  3960. C VARIABLE UNDEFINED
  3961.     CALL ERRMSG(16)
  3962.     RETCD=2
  3963.     RETURN
  3964. C
  3965. C
  3966. C
  3967. 910    IF(NEWTYP.EQ.0) RETURN
  3968.     IF (OLDTYP.EQ.NEWTYP) RETURN
  3969.     GOTO (1000,2000,3000,3000,4000,5000,6000,3000,2000), OLDTYP
  3970.     STOP 1000
  3971. C
  3972. C
  3973. C
  3974. C **************************************************
  3975. C **************  OLDTYP = ASCII  ******************
  3976. C **************************************************
  3977. C
  3978. C  START BY CONVERTING TO INTEGER*4
  3979. 1000    CONTINUE
  3980. C
  3981. C
  3982. C  IF INTEGER, HEXADECIMAL OR OCTAL, ALMOST DONE
  3983.     DO 1002 I=2,8
  3984. 1002    STACK(I,INDXX)=0
  3985.     IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  3986. C
  3987. C
  3988. C
  3989.     DO 1008 I=1,4
  3990. 1008    FOUR(I)=STACK(I,INDXX)
  3991.     IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) GOTO 1200
  3992. C
  3993. C
  3994. C  MULTIPLE PRECISION
  3995. 1010    continue
  3996.     RETURN
  3997. C
  3998. C
  3999. C  DECIMAL OR REAL
  4000. 1200    REAL=DFLOAT(INT)
  4001.     DO 1210 I=1,8
  4002. 1210    STACK(I,INDXX)=EIGHT(I)
  4003.     RETURN
  4004. C
  4005. C
  4006. C
  4007. C **************************************************
  4008. C *********  OLDTYP = DECIMAL OR REAL  *************
  4009. C **************************************************
  4010. C
  4011. 2000    IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) RETURN
  4012. C
  4013. C
  4014.     DO 2002 I=1,8
  4015. 2002    EIGHT(I)=STACK(I,INDXX)
  4016. C
  4017. C
  4018. C  ZERO STACK(I,INDXX)
  4019.     DO 2004 I=1,8
  4020. 2004    STACK(I,INDXX)=CHAR(0)
  4021. C
  4022. C
  4023. C  CONVERT TO INTEGER
  4024. C  MAKE SURE CONVERSION DOESN'T BLOW UP
  4025.     IF(REAL.LT.-2147483648.D0.OR.REAL.GT.2147483647.D0)
  4026.      1 GOTO 6050
  4027. C
  4028. C
  4029. C
  4030. 2007    INT=REAL
  4031. C
  4032. C SEE IF NEWTYP IS MULTIPLE PRECISION
  4033.     IF (NEWTYP.GE.5.AND.NEWTYP.LE.7) GOTO 1010
  4034.     DO 2008 I=1,4
  4035. 2008    STACK(I,INDXX)=FOUR(I)
  4036. C
  4037. C RETURN IF TYPE IS INTEGER, HEX, OR OCTAL
  4038.     IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  4039. C
  4040. C ASCII SO CLEAR OUT BYES 2,3, AND 4
  4041. 2009    DO 2010 I=2,4
  4042. 2010    STACK(I,INDXX)=CHAR(0)
  4043.     RETURN
  4044. C
  4045. C
  4046. C
  4047. C
  4048. C
  4049. C
  4050. C **************************************************
  4051. C *******  OLDTYP = INTEGER, HEX, OR OCTAL  ********
  4052. C **************************************************
  4053. C
  4054. 3000    IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  4055.     DO 3002 I=1,4
  4056. 3002    FOUR(I)=STACK(I,INDXX)
  4057. C
  4058. C SEE IF NEWTYP IS ASCII
  4059.     IF (NEWTYP.EQ.1) GOTO 2009
  4060. C
  4061. C IF NOT REAL*8 THEN IT IS MULTIPLE PRECISION (PROCESS AT 1010)
  4062.     IF (NEWTYP.NE.2.AND.NEWTYP.NE.9) GOTO 1010
  4063. C
  4064. C PROCESS AS REAL*8
  4065.     GOTO 1200
  4066. C
  4067. C *************  OLDTYP = M10  *********************
  4068. C
  4069. 4000    CONTINUE
  4070.     RETURN
  4071. 4040    continue
  4072.     RETURN
  4073. C
  4074. C **************  OLDTYP = M8  *********************
  4075. C
  4076. 5000    CONTINUE
  4077. C ***************  OLDTYP = M16  *******************
  4078. C
  4079. 6000    CONTINUE
  4080.     RETURN
  4081. C
  4082. C ***** ERROR RETURN ******
  4083. 6050    RETCD=2
  4084. C ILLEGAL CONVERSION ATTEMPTED.
  4085.     CALL ERRMSG(26)
  4086.     RETURN
  4087. C
  4088.     END
  4089. c -h- imask.for    Fri Aug 22 12:54:45 1986    
  4090.     INTEGER FUNCTION IMASK(I1,I2)
  4091.     InTeGer*4 I1,I2
  4092.     InTeGer*4 IXX
  4093.     IXX=I1.AND.I2
  4094.     IMASK=IXX
  4095.     RETURN
  4096.     END
  4097.     REAL*8 FUNCTION DFLOAT(IN)
  4098.     INTEGER IN
  4099.     REAL*8 XX
  4100.     XX=IN
  4101.     DFLOAT=XX
  4102.     RETURN
  4103.     END
  4104. C ********ANALYASM.FTN ##################################3
  4105. c AnalytiCalc Amiga specific terminal I/O routines.
  4106. c note ttyini is also special and opens console window...
  4107.     Subroutine SWRT(ibuf,isz)
  4108. c write isz bytes from ibuf onto console window
  4109.     Include dos.inc
  4110.     Integer*4 Isz,i
  4111.     Integer*4 Amiga
  4112.     External Amiga
  4113. C    common/consfh/fh
  4114.     CHARACTER*1 OARRY(100)
  4115.     InTeGer*4 OSWIT,OCNTR
  4116. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  4117. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  4118.     InTeGer*4 IPS1,IPS2,MODFLG
  4119. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  4120.        InTeGer*4 XTCFG,IPSET,XTNCNT
  4121.        CHARACTER*1 XTNCMD(80)
  4122. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  4123. C VARY FLAG ITERATION COUNT
  4124.     INTEGER KALKIT
  4125. C    COMMON/VARYIT/KALKIT
  4126.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  4127.     InTeGer*4 RCMODE,IRCE1,IRCE2
  4128. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  4129. C     1  IRCE2
  4130. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  4131. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  4132. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  4133. C RCFGX ON.
  4134. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  4135. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  4136. C  AND VM INHIBITS. (SETS TO 1).
  4137.     INTEGER*4 FH
  4138. C FILE HANDLE FOR CONSOLE I/O (RAW)
  4139. C    COMMON/CONSFH/FH
  4140.     CHARACTER*1 ARGSTR(52,4)
  4141. C    COMMON/ARGSTR/ARGSTR
  4142.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  4143.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  4144.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  4145.      3  IRCE2,FH,ARGSTR
  4146.     If(fh.ne.0)I=amiga(Write,fh,ibuf,isz)
  4147.     return
  4148.     end
  4149.     Subroutine ttyin(IIMODE,line)
  4150. c read 132 char line off console
  4151. C iimode=0 in Command-Mostly mode, 1 in Enter mostly mode.
  4152.     Integer*4 iact,n,IIMODE
  4153.     include dos.inc
  4154.     Integer*4 Amiga
  4155.     External Amiga
  4156. C    common/consfh/fh
  4157.     CHARACTER*1 OARRY(100)
  4158.     InTeGer*4 OSWIT,OCNTR
  4159. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  4160. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  4161.     InTeGer*4 IPS1,IPS2,MODFLG
  4162. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  4163.        InTeGer*4 XTCFG,IPSET,XTNCNT
  4164.        CHARACTER*1 XTNCMD(80)
  4165. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  4166. C VARY FLAG ITERATION COUNT
  4167.     INTEGER KALKIT
  4168. C    COMMON/VARYIT/KALKIT
  4169.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  4170.     InTeGer*4 RCMODE,IRCE1,IRCE2
  4171. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  4172. C     1  IRCE2
  4173. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  4174. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  4175. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  4176. C RCFGX ON.
  4177. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  4178. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  4179. C  AND VM INHIBITS. (SETS TO 1).
  4180.     INTEGER*4 FH
  4181.     Character*1 wrkchr,lstchr
  4182.     Integer*4 iescst
  4183. C FILE HANDLE FOR CONSOLE I/O (RAW)
  4184. C    COMMON/CONSFH/FH
  4185.     CHARACTER*1 ARGSTR(52,4)
  4186. C    COMMON/ARGSTR/ARGSTR
  4187.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  4188.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  4189.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  4190.      3  IRCE2,FH,ARGSTR
  4191.     character*1 line(132)
  4192.     InTeGer*4 RRWACT,RCLACT
  4193. C    COMMON/RCLACT/RRWACT,RCLACT
  4194.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  4195.      1  IDOL7,IDOL8
  4196. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  4197. C     1  IDOL7,IDOL8
  4198.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  4199. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4200.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  4201. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  4202. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  4203. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  4204.     InTeGer*4 KLVL
  4205. C    COMMON/KLVL/KLVL
  4206.     InTeGer*4 IOLVL,IGOLD
  4207. C    COMMON/IOLVL/IOLVL
  4208. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  4209. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  4210.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  4211.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  4212.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  4213.      3  k3dfg,kcdelt,krdelt,kpag
  4214. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  4215. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  4216. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  4217.     Integer*4 Kone
  4218.     Character*1 xlf
  4219. CCC    InTeGer*4 LLCMD,LLDSP
  4220. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4221. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  4222.     xlf=char(10)
  4223.     iescst=0
  4224.     Kone=1
  4225.     wrkchr=char(0)
  4226. c initially, no ESC seen
  4227. c Set up to read raw: device OK.
  4228. c If we see an ESC character then look for either a return
  4229. c (to terminate in any case) or some character whose value is
  4230. c greater than 64. However ESC O will be passed and the scan will
  4231. c continue.
  4232. C implement deletion of last character also with DEL or with
  4233. C backspace keys
  4234. c
  4235. c Initially zero entire buffer so we later can find length via looking
  4236. c for anything non-zero. Also serves to put in terminators for things
  4237. c like the INDX function to prevent them from running on indefinitely.
  4238.     do 1 n=1,132
  4239. 1    line(n)=char(0)
  4240. c if mode 0, (command mostly) then / is NOT special
  4241.     if(fh.eq.0)goto 1000
  4242. c Here begin the read loop
  4243.     n=1
  4244. 4000    continue
  4245.     lstchr=wrkchr
  4246.     wrkchr=char(0)
  4247. C zero wrkchr for safety
  4248.     iact=amiga(Read,fh,wrkchr,Kone)
  4249.     If(Iact.le.0)goto 4000
  4250.     If(ichar(wrkchr).eq.0)goto 4000
  4251. CCC Add this to just read the line
  4252. CC    iact=amiga(Read,fh,line,132)
  4253. 4050    Continue
  4254.     If(ichar(wrkchr).ne.8.and.ichar(wrkchr).ne.127)goto 4100
  4255. C back up a character and try again
  4256. c Last char was backspace or DEL, so back up by one, echo backspace.
  4257.     n=max0(1,(n-1))
  4258.     lstchr=char(8)
  4259. C echo a backspace
  4260. C 8 is ASCII backspace...
  4261.     ii=Amiga(Write,fh,Lstchr,Kone)
  4262.     Goto 4000
  4263. 4100    Continue
  4264. c C.R. is 13, LF is 10, FF is 14, so terminate on any of these
  4265. c traditional line terminators.
  4266.     If(ichar(wrkchr).lt.16)goto 5000
  4267. c Normal character, just echo it.
  4268.     ii=Amiga(Write,fh,wrkchr,kone)
  4269. c echo the character back
  4270. c Then store it.
  4271.     line(n)=wrkchr
  4272.     n=min0(n+1,131)
  4273.     if(ichar(wrkchr).eq.27.or.ichar(Wrkchr).eq.155)iescst=1
  4274. c <ESC>O is actually an escape sequence initiator
  4275.     If(iescst.eq.1.and.wrkchr.eq.'O'.and.ichar(lstchr)
  4276.      1  .eq.27) goto 4200
  4277. c Otherwise an escape sequence ends in a letter
  4278.     If(Iescst.eq.0)goto 4200
  4279.     ii=ichar(wrkchr)
  4280.     If(ii.eq.91)goto 4200
  4281. c 91 is ascii for [
  4282.     If(ii.gt.64.and.ii.lt.127)Return
  4283. C terminate read at end of any escape sequence
  4284. c from A to z except [ are possible esc seq delimiters.
  4285. 4200    Continue
  4286. c The above condition terminates an ESC sequence after ESC and any other
  4287. c characters followed by (and including) any character greater than 'A'
  4288. c which should take care of just about every ANSI escape sequence.
  4289.     if(n.lt.131)goto 4000
  4290. c Terminate even if we never get C.R. but not 'till we've got
  4291. c all there is to get...
  4292.     Return
  4293. 5000    continue
  4294. c Echo line terminator
  4295.     line(n)=wrkchr
  4296.     ii=Amiga(Write,fh,wrkchr,kone)
  4297.     If(ichar(wrkchr).eq.13)ii=Amiga(Write,fh,xlf,Kone)
  4298. c echo lf after cr
  4299. c done reading now.
  4300.     Return
  4301. 1000    Continue
  4302. C fakeout fallback position, reading workbench window
  4303.     Read(*,1500)line
  4304. 1500    format(132a1)
  4305.     return
  4306.     end
  4307.     subroutine swset(i)
  4308.     integer*4 i
  4309. c dummy setup sub
  4310.     return
  4311.     end
  4312.     subroutine exitqq
  4313. c exit routine ... just do fortran stop to make it complete
  4314.     stop "AnalytiCalc exiting..."
  4315.     end
  4316.     subroutine system(line)
  4317.     include dos.inc
  4318. c execute an amigados command
  4319.     integer*4 inp,outp
  4320.     character*80 line
  4321.     character*80 l2
  4322.     logical*4 succ
  4323.     Logical*4 Amiga
  4324.     External Amiga
  4325.     do 1 n=1,79
  4326.     m=81-n
  4327. c space is ascii code 32
  4328. c look for trailing whitespace to remove
  4329.     if(ichar(line(m:m)).gt.32)goto 2
  4330. 1    continue
  4331. 2    n=m
  4332. c n= last character of non-null
  4333.     k=1
  4334.     if((line(1:1).eq.'$').or.(line(1:1).eq.'}'))k=2
  4335.     open(unit=2,file='ram:AnalyJnk.Tmp',status='new')
  4336.     write(2,1000)line(k:n)
  4337.     if(line(1:1).eq.'$')write(2,1001)
  4338. 1000    format(A)
  4339. 1001    Format('EndCLI')
  4340.     close(unit=2)
  4341.     inp=0
  4342.     outp=0
  4343.     if(line(1:1).eq.'$')l2=
  4344.      1  'NEWCLI CON:0/0/600/190/ASpwn FROM ram:AnalyJnk.Tmp'
  4345.      2  // char(0)
  4346.     if(line(1:1).ne.'$')l2=
  4347.      1  'NEWSHELL CON:0/0/600/190/ASpwn FROM ram:AnalyJnk.Tmp'
  4348.      2  // char(0)
  4349.     succ=amiga(Execute,l2,
  4350.      2  inp,outp)
  4351.     return
  4352.     end
  4353. C ************ AnalyDM.Ftn ######################################
  4354. c -h- declr.for    Fri Aug 22 13:02:54 1986    
  4355.     SUBROUTINE DECLR(ITYP,RETCD)
  4356. C COPYRIGHT (C) 1983 GLENN EVERHART
  4357. C ALL RIGHTS RESERVED
  4358. C 60=MAX REAL ROWS
  4359. C 301=MAX REAL COLS
  4360. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  4361. C VBLS AND TYPE DIMENSIONED 60,301
  4362. C **************************************************
  4363. C *                                                *
  4364. C *       SUBROUTINE  DECLR (ITYP,RETCD)           *
  4365. C *                                                *
  4366. C **************************************************
  4367. C
  4368. C
  4369. C ANALYZES VECTOR LINE TO DETERMINE WHAT VARIABLES GET THEIR
  4370. C TYPES CHANGED. THE NEW TYPE IS SPECIFIED AS AN ARGUMENT IN
  4371. C THE CALL:
  4372. C
  4373. C
  4374. C  TYPE CODE
  4375. C    1  ASCII
  4376. C    2  DECIMAL (REAL BUT DECIMAL POINT FOR OUTPUT)
  4377. C    3  HEXADECIMAL
  4378. C    4  INTEGER
  4379. C    5  MULTIPLE PRECISION (BASE 10)
  4380. C    6  MULTIPLE PRECISION (BASE 8)
  4381. C    7  MULTIPLE PRECISION (BASE 16)
  4382. C    8  OCTAL
  4383. C    9  REAL
  4384. C
  4385. C  IF NEGATIVE, TYPE IS DEFINED BUT VARIABLE HAS
  4386. C  NOT BEEN ASSIGNED A VALUE
  4387. C
  4388. C
  4389. C  RETCD     MEANING
  4390. C  1    =    O.K.
  4391. C  2    =    ERROR
  4392. C
  4393. C  NOTE:  AS IN FORTRAN, VARIABLES IN DECLARATIONS MUST BE SEPARATED
  4394. C         BY COMMAS
  4395. C
  4396. C
  4397. C  MODIFICATION CLASSES: M1, M2
  4398. C
  4399. C
  4400. C
  4401. C
  4402. C DECLR CALLS:
  4403. C
  4404. C  ERRMSG   PRINTS ERROR MESSAGES
  4405. C
  4406. C
  4407. C
  4408. C DECLR IS CALLED BY CMND, THE ROUTINE THAT DECODES COMMANDS.
  4409. C
  4410. C
  4411. C
  4412. C
  4413. C       VARIABLE        USE
  4414. C
  4415. C    ALPHA           LIST OF LEGAL VARIABLE NAMES. THE FIRST 26 ARE
  4416. C                    ALPHABETIC, THE 27TH IS THE CHARACTER '%'.
  4417. C    BLANK           ' '
  4418. C    I,I2,I3         TEMPORARY VALUES.
  4419. C    ITYP            CODE THAT GIVES THE TYPE OF VARIABLE FOR A
  4420. C                    PARTICULAR CALL TO THIS ROUTINE. VARIABLES ARE
  4421. C                    EITHER DECLARED TO BE OF THIS TYPE OR, IF NO
  4422. C                    VARIABLES ARE SPECIFIED, A LIST OF ALL THE
  4423. C                    VARIABLES OF THAT TYPE ARE GIVEN.
  4424. C    LEND            LAST NON-BLANK IN VECTOR LINE(80).
  4425. C    LINE(80)        HOLDS INPUT COMMAND LINE. IF DECLARATION HAS
  4426. C                    NO ARGUMENT, THIS VECTOR IS THEN USED TO OUTPUT
  4427. C                    A LIST OF VARIABLES OF THE TYPE SPECIFIED.
  4428. C    NONBLK          START SCAN OF VARIABLE LIST.
  4429. C    TYPE            HOLDS THE TYPE CODE FOR EACH VARIABLE.
  4430. C
  4431. C
  4432. C
  4433. C
  4434. C
  4435. C
  4436. C
  4437. C    SUBROUTINE DECLR(ITYP,RETCD)
  4438.     InTeGer*4 LEVEL,NONBLK,LEND
  4439.     InTeGer*4  RETCD,VIEWSW,BASED,VLEN(9)
  4440.     InTeGer*4 TYPE(1,1)
  4441.     InTeGer*4 I,I2,I3,ITYP
  4442. C
  4443.     CHARACTER*1  LINE(80),AVBLS(20,27),VBLS(8,1,1)
  4444.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  4445.     Character*127 cwrk
  4446. C
  4447.     COMMON  /V/TYPE,AVBLS,VBLS,VLEN
  4448.     COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  4449.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  4450. C
  4451. C
  4452. C
  4453.     IF(NONBLK.EQ.LEND)GO TO 500
  4454. C
  4455. C
  4456. C **************************************************
  4457. C ****** DECLARE VARIABLES TO BE OF TYPE ITYP ******
  4458. C **************************************************
  4459.     I2=NONBLK+1
  4460. 10    CONTINUE
  4461. C10    IF (LINE(I2).EQ.BLANK) GOTO 60
  4462. C    DO 20 I3=1,26
  4463. C    IF (LINE(I2).EQ.ALPHA(I3)) GOTO 30
  4464. C20    CONTINUE
  4465. C *****&&&&& ADD VARIABLE SIZE SUPPORT - GCE
  4466.     CALL VARSCN(LINE,I2,LEND,LSTCHR,ID1,ID2,IVALID)
  4467. C VARSCN SEARCHES FOR VALID VARIABLE NAME STRINGS INCLUDING C$+EXPR
  4468. C AND R$+EXPR FOR LOC-RELATIVE NAMES IN ABSOLUTE AND C@+N, R@+N FOR RELATIVE
  4469. C NAMES IN DISPLAY SYSTEM. IT RETURNS THE ID1, ID2 INDICES FOR
  4470. C THE VARIABLES IN VBLS ARRAY AND TYPE ARRAY. FOR SINGLE ALPHAS
  4471. C A-Z, ID1 RETURNS 1-26 AND ID2=1. % RETURNS ID1=27, ID2=1.
  4472.     IF(IVALID.EQ.0) GOTO 22
  4473. C VALID FLAG IS NONZERO IF VARIABLE NAME IS VALID, ELSE 0.
  4474.     I2=LSTCHR
  4475. C LSTCHR RETURNS LAST CHARACTER OF NAME
  4476.     GOTO 30
  4477. C
  4478. C  ILLEGAL CHARACTER IN DECLARATION'S VARIABLE LIST
  4479. 22    I=4
  4480. C
  4481. C
  4482. C
  4483. C ******* ERROR RETURN *******
  4484. 25    RETCD=2
  4485.     CALL ERRMSG(I)
  4486.     RETURN
  4487. C
  4488. C
  4489. C
  4490. C
  4491. 30    CONTINUE
  4492. C IF OLD VARIABLE WAS UNDEFINED, MAKE NEW TYPE LESS THAN 0 ALSO.
  4493. C THIS ALLOWS ONE TO EXAMINE INTERNAL VALUES FOR DIFFERENT DATA
  4494. C TYPES. IF THIS IS NOT NEEDED, IT WOULD BE CLEANER TO ALWAYS MAKE
  4495. C VARIABLES UNDEFINED WHEN THEIR DATA TYPE IS CHANGED. TO DO THIS
  4496. C JUST USE THE STATEMENT
  4497. C    I=-ITYP
  4498.     I=ITYP
  4499. C ****&&&&&& NOTE TYPE NOW 2-DIM
  4500.     CALL TYPGET(ID1,ID2,TYPE(1,1))
  4501.     IF(TYPE(1,1).LE.0)I=-I
  4502.     CALL TYPSET(ID1,ID2,I)
  4503. C    TYPE(ID1,ID2)=I
  4504.     I3=I2+1
  4505.     IF (I3.GT.LEND) GOTO 1000
  4506.     DO 40 I2=I3,LEND
  4507.     IF (LINE(I2).EQ.BLANK) GOTO 40
  4508.     IF (LINE(I2).EQ.COMMA) GOTO 45
  4509. C
  4510. C VARIABLES NOT SEPARATED BY COMMAS
  4511.     I=5
  4512.     GO TO 25
  4513. 40    CONTINUE
  4514.     GOTO 1000
  4515. 45    IF (I2.EQ.LEND) GOTO 22
  4516. 60    I2=I2+1
  4517.     IF (I2.LE.LEND) GOTO 10
  4518.     GO TO 1000
  4519. C
  4520. C
  4521. C
  4522. C
  4523. C
  4524. C
  4525. C **********************************************************************
  4526. C ** NO ARGUMENTS SO SHOW WHAT VARIABLES HAVE BEEN DECLARED THAT TYPE **
  4527. C **********************************************************************
  4528. 500    CONTINUE
  4529.     IF(VIEWSW.EQ.0) GO TO 1000
  4530. C PERHAPS THE ABOVE LINE SHOULD BE REMOVED (???)
  4531. C
  4532. C
  4533. C BLANK OUT OUTPUT LINE.
  4534.     DO 510 I=1,80
  4535. 510    LINE(I)=BLANK
  4536. C
  4537. C
  4538. C SEARCH FOR VARIABLES OF TYPE ITYP. PUT THEM IN LINE(I2) WHEN FOUND FOR
  4539. C LATER PRINTING.
  4540.     I2=0
  4541.     DO 550 I=1,27
  4542. C FAKE UP DISPLAY
  4543. C ****&&&&&
  4544.     CALL TYPGET(I,1,TYPE(1,1))
  4545.     IF(IABS(TYPE(1,1)).NE.ITYP)GO TO 550
  4546.     I2=I2+1
  4547.     LINE(I2)=ALPHA(I)
  4548. 550    CONTINUE
  4549. C
  4550. C
  4551. C GO TO SECTION APPROPRIATE FOR PRINTING EITHER THE LIST OF VARIABLES OR
  4552. C A MESSAGE INDICATING THAT NO VARIABLES ARE OF THAT TYPE.
  4553.     IF(I2.EQ.0) GO TO 600
  4554. C
  4555. C
  4556. C OUTPUT A LIST OF VARIABLES OF TYPE ITYP
  4557.     write(cwrk,560)(line(i),i=1,i2)
  4558.     Call vwrt(char(13)//char(10),2)
  4559.     call vwrt('Variables so declared=',22)
  4560.     call vwrt(cwrk,i2)
  4561. c    WRITE(11,560) (LINE(I),I=1,I2)
  4562. 560    format(30a1)
  4563. c560    FORMAT(' VARIABLES SO DECLARED = ',30A1)
  4564.     GO TO 1000
  4565. C
  4566. C
  4567. C
  4568. C
  4569. C NO VARIABLES OF THAT TYPE
  4570. 600    Continue
  4571.     Call vwrt(char(13)//char(10),2)
  4572.     Call vwrt(' No variables of that type',26)
  4573. c600    WRITE(11,610)
  4574. 610    FORMAT(' NO VARIABLES OF THAT TYPE')
  4575. C
  4576. C
  4577. C
  4578. C **** NORMAL RETURN ****
  4579. 1000    RETCD=1
  4580.     RETURN
  4581.     END
  4582. c -h- doentr.for    Fri Aug 22 13:03:06 1986    
  4583.     SUBROUTINE DOENTR(FORM,LOW,LHIGH)
  4584. C +++++++++++++++++++++++++++++++++++
  4585. C PARAMETER 18060=60*301
  4586.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  4587.     INTEGER*4 VNLT
  4588.     DIMENSION FORM(128),FVLD(1,1)
  4589. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  4590. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  4591. C SO INITIALLY IGNORE.
  4592. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4593. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4594.     InTeGer*4 RRWACT,RCLACT
  4595. C    COMMON/RCLACT/RRWACT,RCLACT
  4596.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  4597.      1  IDOL7,IDOL8
  4598. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  4599. C     1  IDOL7,IDOL8
  4600.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  4601. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4602.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  4603. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  4604. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  4605. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  4606.     InTeGer*4 KLVL
  4607. C    COMMON/KLVL/KLVL
  4608.     InTeGer*4 IOLVL,IGOLD
  4609. C    COMMON/IOLVL/IOLVL
  4610. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  4611. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  4612.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  4613.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  4614.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  4615.      3  k3dfg,kcdelt,krdelt,kpag
  4616. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  4617. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  4618. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  4619.     EXTERNAL INDX
  4620.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  4621.     COMMON/D2R/NRDSP,NCDSP
  4622.     InTeGer*4 TYPE(1,1),VLEN(9)
  4623.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  4624.     REAL*8 ACY
  4625.     EQUIVALENCE(ACY,AVBLS(1,27))
  4626.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  4627.     COMMON/FVLDC/FVLD
  4628. C +++++++++++++++++++++++++++++++++++
  4629. C ENABLE { FORMS TO HANDLE ALL POSSIBLE EQUATIONS.
  4630.     CALL FRMEDT(FORM,LLST)
  4631.     IITR=0
  4632. 5050    IITR=IITR+1
  4633.     FORM(111)=Char(0)
  4634.     LCURR=LOW
  4635. C DO AN ENTRY. MUST SCAN FOR MULTIPLE STATEMENTS PER LINE AND ALSO
  4636. C RECOGNIZE FUNCTION NAMES.
  4637. 1000    CONTINUE
  4638.     KKK=ICHAR('\')
  4639.     LSL=INDX(FORM(LCURR),KKK)
  4640.     IF(LSL.EQ.0)LSL=LHIGH-LCURR+1
  4641. C CLAMP AT 80 CHARS LONG INPUT.
  4642.     IF(LSL.LE.79)GOTO 1200
  4643. C STMT HAS NO MULTIPLES. SQUASH IT TO USE ONLY 1ST PART...
  4644.     LSL=79
  4645.     LCURR=LHIGH
  4646.     FORM(80)=Char(0)
  4647. 1200    CONTINUE
  4648.     IF(FORM(LCURR).NE.'<')GOTO 5052
  4649.     IF(ACY.GT.0. .AND.
  4650.      2  IITR.LT.100)GOTO 5050
  4651. C ALLOW IN-FORMULA LOOPING PROVIDED % IS POSITIVE AND
  4652. C WITH LIMITED RETRIES...
  4653. C AVOID CALLING DOSTMT WITH BOGUS < CHARACTER AS "FORMULA" SO
  4654. C WE AVOID ERROR MESSAGES.
  4655.     GOTO 5051
  4656. 5052    CONTINUE
  4657.     CALL DOSTMT(FORM(LCURR),LSL)
  4658. 5051    IF (LCURR.GE.LHIGH)RETURN
  4659.     LCURR=LCURR+LSL
  4660.     If(Lcurr.lt.Lhigh)GOTO 1000
  4661.     Return
  4662.     END
  4663. c -h- doif.for    Fri Aug 22 13:03:17 1986    
  4664.     SUBROUTINE DOIF(LINE,LLB,LRB,LLAST)
  4665. C    PARAMETER 1=1,12=12
  4666.     EXTERNAL INDX
  4667.     CHARACTER*1 LINE(110)
  4668.     REAL*8 V1,V2
  4669.     V1=0.
  4670.     V2=0.
  4671.     LS=LRB-LLB+1
  4672.     CALL GETLOG(LINE(LLB),LS,LOGTYP,LASST)
  4673.     LOV1=LLB
  4674.     LHIV1=LASST+LLB-1
  4675.     IF(LOV1.GE.LHIV1)GOTO 100
  4676. C USE SUM FUNCTION HERE AS TYPE OF FCN
  4677.     LT=4
  4678.     CALL DOMFCN(LINE,LOV1,LHIV1,LT,V1)
  4679. 100    CONTINUE
  4680.     IF(LOGTYP.EQ.0)GOTO 1000
  4681.     LOV2=LASST+2+LLB
  4682.     LHIV2=LRB
  4683.     IF(LOV2.GE.LHIV2)GOTO 200
  4684.     LT=4
  4685.     CALL DOMFCN(LINE,LOV2,LHIV2,LT,V2)
  4686. 200    CONTINUE
  4687.     CALL TEST(LOGTYP,LFLAG,V1,V2)
  4688.     IF(LFLAG.EQ.0)GOTO 700
  4689. C HERE HAVE "TRUE" ALTERNATIVE OF IF STMT
  4690.     KKK=ICHAR('|')
  4691.     LBAR=INDX(LINE,KKK)
  4692.     LBAR=MIN0(LBAR,LLAST)
  4693.     LSTM=LRB+1
  4694. C LSTM TO LBAR IS NOW THE STMT TO EVALUATE. SINCE WE ALREADY HAVE A
  4695. C ROUTINE TO EVALUATE A STMT, DO SO. NOTE PARTIAL RECURSION, SO
  4696. C NO NESTED IFS ALLOWED, AND CALL MUST PERMIT RECURSION ON YOUR
  4697. C MACHINE OR FORGET IT. (OK ON PDP11, VAX).
  4698.     LSZ=LBAR-LSTM
  4699.     IF(LSZ.LT.1)GOTO 1000
  4700.     LSZ=LSZ+1
  4701.     CALL DOSTMI(LINE(LSTM),LSZ)
  4702.     GOTO 1000
  4703. 700    CONTINUE
  4704. C HERE HAVE "FALSE" ALTERNATIVE OF IF STMT
  4705.     KKK=ICHAR('|')
  4706.     LBAR=INDX(LINE,KKK)+1
  4707.     LBAR=MIN0(LBAR,LLAST)
  4708.     LSZ=LLAST-LBAR
  4709.     IF(LSZ.LT.1)GOTO 1000
  4710.     LSZ=LSZ+1
  4711.     CALL DOSTMI(LINE(LBAR),LSZ)
  4712. 1000    CONTINUE
  4713. C THAT'S ALL.
  4714.     RETURN
  4715.     END
  4716. c -h- domath.fms    Fri Aug 22 13:03:28 1986    
  4717.     SUBROUTINE DOMATH(INDEXF,VAR,AC,SS,CTR,ACX)
  4718. C COPYRIGHT (C) 1985, 1986 GLENN C.EVERHART
  4719. C ALL RIGHTS RESERVED
  4720.     INCLUDE APARMS.INC
  4721. C    EXTERNAL INDX
  4722.     REAL*8 AC,SS,CTR,ACX,RWRK1,RWRK2
  4723.     DIMENSION EP(20)
  4724.     InTeGer*4 DLFG
  4725. C    COMMON/DLFG/DLFG
  4726.     InTeGer*4 KDRW,KDCL
  4727. C    COMMON/DOT/KDRW,KDCL
  4728.     InTeGer*4 DTRENA
  4729. C    COMMON/DTRCMN/DTRENA
  4730.     REAL*8 EP,PV,FV
  4731.     DIMENSION EP(20)
  4732.     INTEGER*4 KIRR
  4733. C    COMMON/ERNPER/EP,PV,FV,KIRR
  4734.     InTeGer*4 LASTOP
  4735. C    COMMON/ERROR/LASTOP
  4736.     CHARACTER*1 FMTDAT(9,76)
  4737. C    COMMON/FMTBFR/FMTDAT
  4738.     CHARACTER*1 EDNAM(16)
  4739. C    COMMON/EDNAM/EDNAM
  4740.     InTeGer*4 MFID(2),MFMOD(2)
  4741. C    COMMON/FRM/MFID,MFMOD
  4742.     InTeGer*4 JMVFG,JMVOLD
  4743. C    COMMON/FUBAR/JMVFG,JMVOLD
  4744.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  4745.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  4746. CCC    REAL*8 EP,PV,FV
  4747. CCC    COMMON/ERNPER/EP,PV,FV,KIRR
  4748.     REAL*8 VAR,TE
  4749.     INTEGER*4 IWRK1,IWRK2,IDUM
  4750.     LOGICAL*4 LWRK1,LWRK2,LWRK3
  4751.     INTEGER*4 IWRK3
  4752.     EQUIVALENCE(IWRK1,LWRK1),(IWRK2,LWRK2),(IWRK3,LWRK3)
  4753.     InTeGer*4 ICREF,IRREF
  4754. C    COMMON/MIRROR/ICREF,IRREF
  4755.     InTeGer*4 MODPUB,LIMODE
  4756. C    COMMON/MODPUB/MODPUB,LIMODE
  4757.     InTeGer*4 KLKC,KLKR
  4758.     REAL*8 AACP,AACQ
  4759. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  4760.     InTeGer*4 NCEL,NXINI
  4761. C    COMMON/NCEL/NCEL,NXINI
  4762.     CHARACTER*1 NAMARY(20,MROWS)
  4763. C    COMMON/NMNMNM/NAMARY
  4764.     InTeGer*4 NULAST,LFVD
  4765. C    COMMON/NULXXX/NULAST,LFVD
  4766.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  4767.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  4768. CCC    REAL*8 AACP,AACQ
  4769. CCC    InTeGer*4 KLKC,KLKR
  4770. CCC    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  4771.     IF(INDEXF.NE.1)GOTO 100
  4772. C MIN
  4773.     IF(VAR.GE.AC)GOTO 105
  4774.     AC=VAR
  4775.     AACP=KLKC
  4776.     AACQ=KLKR
  4777. 105    CONTINUE
  4778.     ACX=AC
  4779.     RETURN
  4780. 100    IF(INDEXF.NE.2)GOTO 200
  4781. C MAX
  4782.     IF(VAR.LE.AC)GOTO 107
  4783.     AC=VAR
  4784.     AACP=KLKC
  4785.     AACQ=KLKR
  4786. 107    CONTINUE
  4787. C    IF(VAR.GT.AC)AC=VAR
  4788.     ACX=AC
  4789.     RETURN
  4790. 200    IF(INDEXF.NE.3)GOTO 300
  4791. C AVG
  4792.     AC=AC+VAR
  4793.     CTR=CTR+1.
  4794.     ACX=AC/CTR
  4795.     RETURN
  4796. 300    IF(INDEXF.NE.4)GOTO 400
  4797. C SUM
  4798.     AC=AC+VAR
  4799.     ACX=AC
  4800.     RETURN
  4801. 400    IF(INDEXF.NE.5)GOTO 500
  4802. C STD (STANDARD DEVIATION SQUARED)
  4803.     AC=AC+VAR
  4804.     SS=SS+(VAR*VAR)
  4805.     CTR=CTR+1.
  4806.     ACX=(SS-((AC*AC)/CTR))/CTR
  4807.     RETURN
  4808. 500    CONTINUE
  4809.     IF(INDEXF.NE.7)GOTO 600
  4810. C AND
  4811.     IF(SS.NE.0.)IWRK1=AC
  4812.     IF(SS.EQ.0.)IWRK1=VAR
  4813.     SS=1.
  4814.     IWRK2=VAR
  4815.     LWRK1=LWRK1.AND.LWRK2
  4816.     AC=IWRK1
  4817.     ACX=AC
  4818.     RETURN
  4819. 600    IF(INDEXF.NE.8)GOTO 700
  4820. C INCLUSIVE OR
  4821.     IWRK1=AC
  4822.     IWRK2=VAR
  4823.     LWRK1=LWRK1.OR.LWRK2
  4824.     AC=IWRK1
  4825.     ACX=AC
  4826.     RETURN
  4827. 700    IF (INDEXF.NE.9)GOTO 800
  4828. C NOT
  4829.     IWRK1=VAR
  4830.     LWRK1=.NOT.LWRK1
  4831.     AC=IWRK1
  4832.     ACX=AC
  4833.     RETURN
  4834. 800    IF(INDEXF.NE.10)GOTO 1000
  4835. C CNT
  4836. C COUNT NONZERO ENTRIES
  4837.     IF(VAR.NE.0.)AC=AC+1.
  4838.     ACX=AC
  4839.     RETURN
  4840. 1000    CONTINUE
  4841.     IF(INDEXF.NE.11)GOTO 1100
  4842. C NPV
  4843.     IF(SS.EQ.0.)GOTO 1050
  4844.     CTR=CTR+1.
  4845. C    AC=AC+VAR*CTR/SS
  4846.     AC=AC+VAR/(SS**(CTR-1))
  4847.     ACX=AC
  4848.     RETURN
  4849. C    GOTO 1200
  4850. 1050    CONTINUE
  4851.     SS=VAR+1.
  4852.     ACX=0.
  4853.     RETURN
  4854. 1100    if(indexf.ne.12) GOTO 1200
  4855. C LKP
  4856.     IF(SS.NE.0.)GOTO 1150
  4857.     SS=1.
  4858.     AC=VAR
  4859.     ACX=-1.
  4860.     RETURN
  4861. C    GOTO 1200
  4862. 1150    CONTINUE
  4863. C    IF(VAR.GE.AC.AND.ACX.LT.0.)ACX=CTR
  4864.     IF(VAR.LT.AC.OR.ACX.GE.0.)GOTO 1155
  4865.     ACX=CTR
  4866.     AACP=KLKC
  4867.     AACQ=KLKR
  4868. 1155    CONTINUE
  4869.     CTR=CTR+1.
  4870.     RETURN
  4871. 1200    CONTINUE
  4872.     IF(INDEXF.NE.13)GOTO 1300
  4873. C LKN
  4874.     IF(SS.NE.0.)GOTO 1250
  4875.     SS=1.
  4876.     AC=VAR
  4877.     ACX=-1.
  4878.     GOTO 1300
  4879. 1250    CONTINUE
  4880. C    IF(VAR.LE.AC.AND.ACX.LT.0.)ACX=CTR
  4881.     IF(VAR.GT.AC.OR.ACX.GT.0.)GOTO 1256
  4882.     ACX=CTR
  4883.     AACP=KLKC
  4884.     AACQ=KLKR
  4885. 1256    CONTINUE
  4886.     CTR=CTR+1.
  4887.     RETURN
  4888. 1300    CONTINUE
  4889.     IF(INDEXF.NE.14)GOTO 1400
  4890. C LKE
  4891.     IF(SS.NE.0.)GOTO 1350
  4892.     SS=1.
  4893.     AC=VAR
  4894.     ACX=-1.
  4895.     GOTO 1400
  4896. 1350    CONTINUE
  4897. C    IF(VAR.EQ.AC.AND.ACX.LT.0.)ACX=CTR
  4898.     IF(VAR.NE.AC.OR.ACX.GE.0.)GOTO 1355
  4899.     ACX=CTR
  4900.     AACP=KLKC
  4901.     AACQ=KLKR
  4902. 1355    CONTINUE
  4903.     CTR=CTR+1.
  4904.     RETURN
  4905. 1400    CONTINUE
  4906.     IF(INDEXF.NE.15)GOTO 1500
  4907. C XOR
  4908.     IF(SS.NE.0)IWRK1=AC
  4909.     IF(SS.EQ.0)IWRK1=VAR
  4910.     SS=SS+1.
  4911.     IF(SS.EQ.1.)GOTO 1405
  4912.     IWRK2=VAR
  4913.     LWRK3=LWRK1.OR.LWRK2
  4914.     LWRK1=LWRK1.AND.LWRK2
  4915.     IWRK1=IWRK3-IWRK1
  4916. 1405    AC=IWRK1
  4917.     ACX=AC
  4918.     RETURN
  4919. 1500    CONTINUE
  4920.     IF(INDEXF.NE.16)GOTO 1600
  4921. C EQV
  4922. C NOTE THE EQUIVALENCE FUNCTION IS JUST THE COMPLEMENT OF
  4923. C THE XOR FUNCTION. DO THE COMPLEMENT VIA THE .NOT. OPERATOR.
  4924.     IF(SS.NE.0)IWRK1=AC
  4925.     IF(SS.EQ.0)IWRK1=VAR
  4926.     SS=SS+1.
  4927.     IF(SS.EQ.1.)GOTO 1505
  4928.     IWRK2=VAR
  4929.     LWRK3=LWRK1.OR.LWRK2
  4930.     LWRK1=LWRK1.AND.LWRK2
  4931.     IWRK1=IWRK3-IWRK1
  4932.     LWRK1=.NOT.LWRK1
  4933. 1505    AC=IWRK1
  4934.     ACX=AC
  4935.     RETURN
  4936. 1600    CONTINUE
  4937.     IF(INDEXF.NE.17)GOTO 1700
  4938. C MOD
  4939. C MODULO (V1 MOD V2)
  4940.     IF(SS.NE.0)RWRK1=AC
  4941.     IF(SS.EQ.0)RWRK1=VAR
  4942.     SS=SS+1.
  4943.     IF(SS.EQ.1.)GOTO 1605
  4944.     RWRK2=VAR
  4945.     RWRK1=DMOD(RWRK1,RWRK2)
  4946. 1605    AC=RWRK1
  4947.     ACX=AC
  4948.     RETURN
  4949. 1700    CONTINUE
  4950.     IF(INDEXF.NE.18)GOTO 1800
  4951. C REMAINDER -- INTEGER MODULO
  4952.     IF(SS.NE.0)IWRK1=AC
  4953.     IF(SS.EQ.0)IWRK1=VAR
  4954.     SS=SS+1.
  4955.     IF(SS.EQ.1.)GOTO 1705
  4956.     IWRK2=VAR
  4957.     IWRK1=JMOD(IWRK1,IWRK2)
  4958. 1705    AC=IWRK1
  4959.     ACX=AC
  4960.     RETURN
  4961. 1800    CONTINUE
  4962.     IF(INDEXF.NE.19)GOTO 1900
  4963. C SGN
  4964. C RETURN 1.0 * SIGN OF ARGUMENT.
  4965.     AC=DSIGN(1.0D0,VAR)
  4966.     ACX=AC
  4967.     RETURN
  4968. 1900    CONTINUE
  4969.     IF(INDEXF.NE.20)GOTO 2000
  4970. C IRR - INTERNAL RATE OF RETURN
  4971.     AC=0.
  4972.     ACX=0.
  4973.     IF(KIRR.LT.20)KIRR=KIRR+1
  4974.     IF(KIRR.EQ.1)PV=VAR
  4975.     IF(KIRR.EQ.2)FV=VAR
  4976.     IF(KIRR.LT.3)RETURN
  4977. C IRRPV,FV,RETURNS...
  4978.     IWRK1=KIRR-2
  4979.     EP(IWRK1)=VAR
  4980.     RWRK1=.15
  4981.     RWRK2=.25
  4982. C ITERATIVELY SOLVE FOR INTERNAL RATE OF RETURN.
  4983. 1903    TE=0.
  4984.     SS=FV/((1.D0+RWRK1)**(IWRK1))
  4985.     DO 1905 IWRK2=1,IWRK1
  4986.     AC=EP(IWRK2)/((1.D0+RWRK1)**IWRK2)
  4987.     SS=SS+AC
  4988. 1905    CONTINUE
  4989.     RWRK2=RWRK1*(SS+TE)/PV
  4990.     IF(DABS(RWRK1-RWRK2).LT..00001)GOTO 1910
  4991.     RWRK1=RWRK2
  4992.     GOTO 1903
  4993. 1910    CONTINUE
  4994.     AC=RWRK2
  4995.     ACX=AC
  4996.     RETURN
  4997. 2000    CONTINUE
  4998.     IF(INDEXF.NE.21)GOTO 2100
  4999. C RND[] - RANDOM NUMBER RETURN
  5000.     AC=RND(IDUM)
  5001.     ACX=AC
  5002.     RETURN
  5003. 2100    CONTINUE
  5004.        IF(INDEXF.NE.22)GOTO 2200
  5005. C PMT FUNCTION
  5006. C PMT[PRINCIPAL, INTEREST, NPERIODS] ARE ARGS
  5007. C PAYMENT (MORTGAGE PAYMENT PER PERIOD
  5008. C COMPUTED AS PAYMENT=PRINCIPAL*(INTEREST/(1-(1+INTEREST)**NPERIODS))
  5009. C (CORRECT EVEN IF INTEREST=0
  5010. C (REUSE COUNTER USED IN IRR ARGUMENTS HERE)
  5011.     AC=0.
  5012.     ACX=0.
  5013.     KIRR=KIRR+1
  5014.     EP(KIRR)=VAR
  5015.     IF(KIRR.LT.3)RETURN
  5016. C FIRST GET ALL THE INPUTS, THEN DO THE REAL RESULT.
  5017.     AC=EP(1)*(EP(2)/(1.-((1.+EP(2))**(-EP(3)))))
  5018.     ACX=AC
  5019.     RETURN
  5020. 2200    CONTINUE
  5021.     IF(INDEXF.NE.23)GOTO 2300
  5022. C PVL FUNCTION
  5023. C PVL[PAYMENT,INTEREST,NPERIODS] ARE ARGS
  5024. C PRESENT VALUE COMPUTED AS
  5025. C PV=PAYMENT*(1.-(1.+INTEREST)**-NPERIODS)/INTEREST
  5026. C (REUSE COUNTER USED IN IRR ARGUMENTS HERE)
  5027.     AC=0.
  5028.     ACX=0.
  5029.     KIRR=KIRR+1
  5030.     EP(KIRR)=VAR
  5031.     IF(KIRR.LT.3)RETURN
  5032. C FIRST GET ALL THE INPUTS, THEN DO THE REAL RESULT.
  5033.     AC=EP(1)*EP(3)
  5034.     IF(EP(3).EQ.0..OR.EP(2).EQ.0.)GOTO 2205
  5035.     AC=EP(1)*((1.-(1.+EP(2))**(-EP(3)))/EP(2))
  5036. 2205    ACX=AC
  5037.     RETURN
  5038. 2300    CONTINUE
  5039.     IF(INDEXF.NE.24)GOTO 2400
  5040. C AVE AVERAGE EXCLUDING ZERO CELLS
  5041.     IF(VAR.EQ.0.)GOTO 2305
  5042.     AC=AC+VAR
  5043.     CTR=CTR+1.
  5044. 2305    ACX=AC/DMAX1(CTR,1.0D0)
  5045.     RETURN
  5046. 2400    CONTINUE
  5047.     IF(INDEXF.NE.25)GOTO 2500
  5048. C CHS
  5049. C CHOOSE FROM ARGS USING 1ST ARG AS COUNT INTO RANGE...
  5050. C (SIMILAR TO CLASSICAL "CHOOSE" FUNCTION...)
  5051. C RETURNS 0.0 OR VALUE OF NTH ARG WHERE N IS INDEX OF ARG...
  5052. C    IF(KIRR.EQ.0)ACX=0.
  5053.     KIRR=KIRR+1
  5054.     IF(KIRR.EQ.1)IWRK1=VAR+1.
  5055.     IF(KIRR.NE.IWRK1)GOTO 2450
  5056. C SAVE LOCATION ALSO OF CELLS.
  5057. C THIS ALLOWS US TO FIND ADDRESSES OF SELECTED CELLS IN CHOOSE FOR ADDRESS MATH.
  5058.     AACP=KLKC
  5059.     AACQ=KLKR
  5060.     SS=VAR
  5061. 2450    CONTINUE
  5062.     ACX=SS
  5063.     AC=ACX
  5064.     RETURN
  5065. 2500    CONTINUE
  5066.     IF(INDEXF.NE.26)GOTO 2600
  5067. C ATM ARCTAN OF 2 ARGS
  5068.     IF(SS.NE.0.)RWRK1=AC
  5069.     IF(SS.EQ.0.)RWRK1=VAR
  5070.     SS=SS+1.
  5071.     IF(SS.LE.1.1)GOTO 2505
  5072.     RWRK2=VAR
  5073. C GET 4 QUADRANT ARCTAN
  5074.     RWRK1=DATAN2(RWRK1,RWRK2)
  5075. 2505    AC=RWRK1
  5076.     ACX=AC
  5077.     RETURN
  5078. 2600    CONTINUE
  5079.     RETURN
  5080.     END
  5081. c -h- domfcn.for    Fri Aug 22 13:03:40 1986    
  5082.     SUBROUTINE DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
  5083. C LLB = LOC OF
  5084. C LRB = LOC OF
  5085. C INDEXF IS AS ABOVE. GUARANTEED IN RANGE 1-5.
  5086.     INCLUDE APARMS.INC
  5087.     CHARACTER*1 LINE(110)
  5088. C +++++++++++++++++++++++++++++++++++
  5089. C PARAMETER 18060=60*301
  5090.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  5091.     EXTERNAL INDX
  5092.     INTEGER*4 VNLT
  5093.     DIMENSION FORM(128),FVLD(1,1)
  5094. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  5095. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  5096. C SO INITIALLY IGNORE.
  5097. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5098. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5099.     InTeGer*4 RRWACT,RCLACT
  5100. C    COMMON/RCLACT/RRWACT,RCLACT
  5101.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  5102.      1  IDOL7,IDOL8
  5103. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  5104. C     1  IDOL7,IDOL8
  5105.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  5106. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5107.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5108. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5109. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  5110. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  5111.     InTeGer*4 KLVL,k3dfg,kcdelt,krdelt,kshtf
  5112. C    COMMON/KLVL/KLVL
  5113.     InTeGer*4 IOLVL,IGOLD
  5114. C    COMMON/IOLVL/IOLVL
  5115. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  5116. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  5117.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5118.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5119.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5120.      3  k3dfg,kcdelt,krdelt,kshtf
  5121. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5122. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5123. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5124. c     3  K3DFG,KCDelt,KRDelt,kpag
  5125.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  5126.     COMMON/D2R/NRDSP,NCDSP
  5127.     InTeGer*4 TYPE(1,1),VLEN(9)
  5128.     REAL*8 XVBLS(1,1)
  5129.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  5130.     INTEGER*4 JVBLS(2,1,1)
  5131.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  5132.     REAL*8 XXX
  5133.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  5134.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  5135.     REAL*8 ACX,ACY
  5136.     REAL*8 AC,SS,CTR
  5137.     EQUIVALENCE(ACY,AVBLS(1,27))
  5138.     InTeGer*4 DLFG
  5139. C    COMMON/DLFG/DLFG
  5140.     InTeGer*4 KDRW,KDCL
  5141. C    COMMON/DOT/KDRW,KDCL
  5142.     InTeGer*4 DTRENA
  5143. C    COMMON/DTRCMN/DTRENA
  5144.     REAL*8 EP,PV,FV
  5145.     DIMENSION EP(20)
  5146.     INTEGER*4 KIRR
  5147. C    COMMON/ERNPER/EP,PV,FV,KIRR
  5148.     InTeGer*4 LASTOP
  5149. C    COMMON/ERROR/LASTOP
  5150.     CHARACTER*1 FMTDAT(9,76)
  5151. C    COMMON/FMTBFR/FMTDAT
  5152.     CHARACTER*1 EDNAM(16)
  5153. C    COMMON/EDNAM/EDNAM
  5154.     InTeGer*4 MFID(2),MFMOD(2)
  5155. C    COMMON/FRM/MFID,MFMOD
  5156.     InTeGer*4 JMVFG,JMVOLD
  5157. C    COMMON/FUBAR/JMVFG,JMVOLD
  5158.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  5159.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  5160. CCC    InTeGer*4 KDRW,KDCL
  5161. CCC    COMMON /DOT/KDRW,KDCL
  5162.     CHARACTER*1 ILINE(106)
  5163.     InTeGer*4 ILNFG,ILNCT
  5164.     COMMON/ILN/ILNFG,ILNCT,ILINE
  5165.     COMMON/FVLDC/FVLD
  5166.     InTeGer*4 ICREF,IRREF
  5167. C    COMMON/MIRROR/ICREF,IRREF
  5168.     InTeGer*4 MODPUB,LIMODE
  5169. C    COMMON/MODPUB/MODPUB,LIMODE
  5170.     InTeGer*4 KLKC,KLKR
  5171.     REAL*8 AACP,AACQ
  5172. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  5173.     InTeGer*4 NCEL,NXINI
  5174. C    COMMON/NCEL/NCEL,NXINI
  5175.     CHARACTER*1 NAMARY(20,MROWS)
  5176. C    COMMON/NMNMNM/NAMARY
  5177.     InTeGer*4 NULAST,LFVD
  5178. C    COMMON/NULXXX/NULAST,LFVD
  5179.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  5180.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  5181. CCC    InTeGer*4 KLKC,KLKR
  5182.     REAL*8 ACP,ACQ
  5183. CCC    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  5184.     EQUIVALENCE(ACP,AVBLS(1,16)),(ACQ,AVBLS(1,17))
  5185. C +++++++++++++++++++++++++++++++++++
  5186. C
  5187. C FIRST GET A VARIABLE NAME. ALL MATH FUNCTIONS REQUIRE VARIABLE
  5188. C NAMES SINCE THEIR VARIABLES ARE THEIR ONLY VALID ARGS.
  5189.     CALL MTHINI(INDEXF,AC,SS,CTR,ACX)
  5190. C SET UP PROPER INITS
  5191. C KV2=1 IF A 2ND VBL EXISTS
  5192.     LCR=LLB+1
  5193.     AACP=ACP
  5194.     AACQ=ACQ
  5195. C INIT SAVED P, Q AC'S HERE IN CASE DOMATH MODIFIES...
  5196. C THIS ALLOWS SELECTION FUNCTIONS TO SET COL, ROW IN P AND Q AC.
  5197. 100    CONTINUE
  5198.     KV2=0
  5199.     LB=LCR
  5200.     LE=LRB-1
  5201.     IF(LB.GE.LE)RETURN
  5202.     CALL VARSCN(LINE,LB,LE,LASST,ID1,ID2,IVALID)
  5203.     IF(IVALID.EQ.0)RETURN
  5204. C USE extra cell to check for different sheets, same row/col
  5205. C use separator of } to indicate range is depth.
  5206.     KPG1=KSHTF
  5207.     KDEPSP=0
  5208.     if(Line(Lasst).eq.'}')Goto 8601
  5209.     IF(LINE(LASST).NE.':')GOTO 110
  5210.     Goto 8603
  5211. 8601    Continue
  5212.     KDepsp=1
  5213. 8603    Continue
  5214.     LB=LASST+1
  5215.     LE=LRB-1
  5216.     CALL VARSCN(LINE,LB,LE,LASST,ID1B,ID2B,IVALID)
  5217.     IF(IVALID.NE.0)KV2=1
  5218.     KPG2=KSHTF
  5219.     If(KDepsp.ne.1)goto 8604
  5220.     KDp=0
  5221.     If (kv2.eq.0)goto 8606
  5222.     KDp=kpg2-kpg1
  5223. C KDp is depth to go through. If negative set to zero.
  5224.     if(KDp.lt.0)kdp=0
  5225. 8606    Continue
  5226. 8605    Continue
  5227.     CALL XVBLGT(ID1,ID2,XVBLS(1,1))
  5228.     XXX=XVBLS(1,1)
  5229.     CALL TYPGET(ID1,ID2,TYPE(1,1))
  5230. C USE EQUIVALENCE OF JVBLS AND XVBLS
  5231.     IF(ABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
  5232.     KLKC=ID1
  5233.     KLKR=ID2-1
  5234.     CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
  5235.     id1=id1+kcdelt
  5236.     id2=id2+krdelt
  5237.     kdp=kdp-1
  5238. C Handle all math over the depth argument.
  5239. C (Only partially decode; if argument is ill-formed
  5240. C  then just act as if range were directly below the
  5241. C  top cell.)
  5242.     if(KDp.ge.0)goto 8605
  5243.     GoTo 200
  5244. 8604    Continue
  5245. 110    CONTINUE
  5246.     CALL XVBLGT(ID1,ID2,XVBLS(1,1))
  5247.     XXX=XVBLS(1,1)
  5248. C    XXX=XVBLS(ID1,ID2)
  5249.     CALL TYPGET(ID1,ID2,TYPE(1,1))
  5250. C USE EQUIVALENCE OF JVBLS AND XVBLS
  5251.     IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
  5252.     KLKC=ID1
  5253.     KLKR=ID2-1
  5254.     CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
  5255.     IF(KV2.EQ.0)GOTO 200
  5256.     IF(ID1.NE.ID1B) GOTO 120
  5257.     IF(ID2.GT.ID2B)GOTO 200
  5258.     M=ID2+1
  5259.     DO 121 MM=M,ID2B
  5260.     CALL XVBLGT(ID1,MM,XVBLS(1,1))
  5261.     XXX=XVBLS(1,1)
  5262.     CALL TYPGET(ID1,MM,TYPE(1,1))
  5263. C    XXX=XVBLS(ID1,MM)
  5264.     IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
  5265.     KLKC=ID1
  5266.     KLKR=MM-1
  5267.     CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
  5268. 121    CONTINUE
  5269.     GOTO 200
  5270. 120    CONTINUE
  5271.     IF(ID2.NE.ID2B)GOTO 130
  5272.     IF(ID1.GT.ID1B)GOTO 200
  5273.     M=ID1+1
  5274.     DO 131 MM=M,ID1B
  5275.     CALL XVBLGT(MM,ID2,XVBLS(1,1))
  5276.     XXX=XVBLS(1,1)
  5277. C    XXX=XVBLS(MM,ID2)
  5278.     CALL TYPGET(MM,ID2,TYPE(1,1))
  5279.     IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
  5280.     KLKC=MM
  5281.     KLKR=ID2-1
  5282.     CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
  5283. 131    CONTINUE
  5284. 130    CONTINUE
  5285. 200    CONTINUE
  5286. C IF NEXT CHAR IS A COMMA, SKIP IT AND KEEP UP SCAN UNLESS DONE
  5287.     IF(LINE(LASST).EQ.',')GOTO 300
  5288.     ACP=AACP
  5289.     ACQ=AACQ
  5290. C USE P, Q ACCUMULATORS FOR SELECTED COL, ROW COORDS FROM DOMATH
  5291.     RETURN
  5292. 300    LCR=LASST+1
  5293.     GOTO 100
  5294.     END
  5295. c -h- dostmi.for    Fri Aug 22 13:03:55 1986    
  5296.     SUBROUTINE DOSTMI(LINE,LLAST)
  5297. C COPY OF DOSTMT FOR IF FUNCTION.
  5298. C HANDLE 1 STATEMENT PARSING (DOES A BIT MORE OF THE WORK WITH THE
  5299. C PART OF THE LINE STRIPPED TO HAVE EXACTLY ONE COMMAND IN IT.
  5300.     CHARACTER*1 LINE(110)
  5301. C +++++++++++++++++++++++++++++++++++
  5302. C PARAMETER 18060=60*301
  5303.     EXTERNAL INDX
  5304.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  5305.     INTEGER*4 VNLT
  5306.     DIMENSION FORM(128),FVLD(1,1)
  5307. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  5308. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  5309. C SO INITIALLY IGNORE.
  5310.     COMMON/FVLDC/FVLD
  5311. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5312. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5313.     InTeGer*4 RRWACT,RCLACT
  5314. C    COMMON/RCLACT/RRWACT,RCLACT
  5315.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  5316.      1  IDOL7,IDOL8
  5317. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  5318. C     1  IDOL7,IDOL8
  5319.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  5320. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5321.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5322. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5323. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  5324. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  5325.     InTeGer*4 KLVL
  5326. C    COMMON/KLVL/KLVL
  5327.     InTeGer*4 IOLVL,IGOLD
  5328. C    COMMON/IOLVL/IOLVL
  5329. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  5330. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  5331.  
  5332.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5333.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5334.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5335.      3  k3dfg,kcdelt,krdelt,kpag
  5336. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5337. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5338. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  5339.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  5340.     COMMON/D2R/NRDSP,NCDSP
  5341.     InTeGer*4 TYPE(1,1),VLEN(9)
  5342.     REAL*8 XVBLS(1,1)
  5343.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  5344.     INTEGER*4 JVBLS(2,1,1)
  5345.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  5346.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  5347.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  5348.     REAL*8 ACX,ACY,AACY
  5349.     INTEGER*4 IACY,IIJACY
  5350.     EQUIVALENCE(IIJACY,AACY)
  5351.     EQUIVALENCE(IACY,AVBLS(1,27))
  5352.     EQUIVALENCE(ACY,AVBLS(1,27))
  5353.     InTeGer*4 DLFG
  5354. C    COMMON/DLFG/DLFG
  5355.     InTeGer*4 KDRW,KDCL
  5356. C    COMMON/DOT/KDRW,KDCL
  5357.     InTeGer*4 DTRENA
  5358. C    COMMON/DTRCMN/DTRENA
  5359.     REAL*8 EP,PV,FV
  5360.     DIMENSION EP(20)
  5361.     INTEGER*4 KIRR
  5362. C    COMMON/ERNPER/EP,PV,FV,KIRR
  5363.     InTeGer*4 LASTOP
  5364. C    COMMON/ERROR/LASTOP
  5365.     CHARACTER*1 FMTDAT(9,76)
  5366. C    COMMON/FMTBFR/FMTDAT
  5367.     CHARACTER*1 EDNAM(16)
  5368. C    COMMON/EDNAM/EDNAM
  5369.     InTeGer*4 MFID(2),MFMOD(2)
  5370. C    COMMON/FRM/MFID,MFMOD
  5371.     InTeGer*4 JMVFG,JMVOLD
  5372. C    COMMON/FUBAR/JMVFG,JMVOLD
  5373.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  5374.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  5375. CCC    InTeGer*4 KDRW,KDCL
  5376. CCC    COMMON /DOT/KDRW,KDCL
  5377.     CHARACTER*1 ILINE(106)
  5378.     InTeGer*4 ILNFG,ILNCT
  5379.     COMMON/ILN/ILNFG,ILNCT,ILINE
  5380. C +++++++++++++++++++++++++++++++++++
  5381.     CALL FNAME(LINE,LLAST,INDEXF)
  5382. C ABOVE GETS FUNCTION NAMES.
  5383. C    NAME    INDEXF
  5384. C    MIN    1
  5385. C    MAX    2
  5386. C    AVG    3
  5387. C    SUM    4
  5388. C    STD    5    (STD DEVIATION)
  5389. C    IF    6    (IF STMT)
  5390. C    AND    7
  5391. C    OR    8
  5392. C    NOT    9
  5393. C    CNT    10 (COUNTS NONZERO ENTRIES)
  5394. C    NPV    11 NET PRESENT VALUE
  5395. C    LKP    12 LOOKUP IN LIST, GIVE OFFSET 0 BASED
  5396. C    LKN    13    LOOKUP NEGATIVE (INVERSE OF LKP)
  5397. C    LKE    14    LOOKUP EQUAL
  5398. C    XOR    15    EXCLUSIVE OR
  5399. C    EQV    16    EQUIVALENCE (TRUE IF BITS EQUAL)
  5400. C    MOD    17    V1 MODULO V2
  5401. C    REM    18    REMAINDER OF V1/V2
  5402. C    SGN    19    SIGN OF V1 (-1.,0., OR +1.)
  5403. C    IRR    20    INTERNAL RATE OF RETURN
  5404. C USE  AND  TO DELIMIT FUNCTION ARGS.
  5405. C *****************************************************************************
  5406. C **** NOTE: MAX 20 IS KEPT AS A LITERAL IN NEXTEL ALSO AS FLAG THAT FUNCTION
  5407. C **** FAILED TO FIND VALID LITERAL. CHANGE THERE TOO IF YOU ADD MORE FUNCTIONS.
  5408.     IF(INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 1000
  5409. C HERE IF A FUNCTION OR AN IF STMT (FORMAT= IF varRELvarstmt|else-stmt)
  5410. C
  5411. C ALLOW CALC TO HANDLE ALL BUT IF STMTS
  5412.     IF(INDEXF.NE.6)GOTO 1000
  5413. C
  5414. C **** FIXUP '' NEXT. 2 LINES. REPLACE HERE... ***
  5415.     KKK=ICHAR('[')
  5416.     LLB=INDX(LINE,KKK)
  5417.     KKK=ICHAR(']')
  5418.     LRB=INDX(LINE,KKK)
  5419. C *** ERROR WITH FORMAT -- NO  SEEN IN TIME. JUST IGNORE IT.
  5420.     IF(LLB.GT.LLAST)RETURN
  5421.     IF(LRB.GT.LLAST)LRB=LLAST
  5422. C ** COMMENT OUT NEVER-USED CODE NEXT AREA...
  5423. C
  5424. C    IF(INDEXF.EQ.6)GOTO 2000
  5425. CC ISOLATE MATH FUNCTIONS
  5426. C    CALL DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
  5427. CC GET % ABOVE
  5428. C    CALL TYPGET(KDRW,KDCL,TYPE(1,1))
  5429. C    IF(IABS(TYPE(1,1)).NE.2)GOTO 1760
  5430. C    CALL XVBLST(KDRW,KDCL,ACX)
  5431. CC    XVBLS(KDRW,KDCL)=ACX
  5432. CC LEAVE RESULT IN % TOO.
  5433. C    ACY=ACX
  5434. C    CALL TYPSET(27,1,TYPE(1,1))
  5435. CC    TYPE(27,1)=TYPE(KDRW,KDCL)
  5436. C    RETURN
  5437. C1760    JVBLS(1,1,1)=ACX
  5438. C    CALL JVBLST(1,KDRW,KDCL,JVBLS(1,1,1))
  5439. CC    JVBLS(1,KDRW,KDCL)=ACX
  5440. C    RETURN
  5441. 2000    CONTINUE
  5442. C HANDLE AN "IF" STATEMENT
  5443. C ILLEGAL HERE INSIDE AN IF, SO JUST IGNORE IT.
  5444. C    CALL DOIF(LINE,LLB,LRB,LLAST)
  5445. C PASS LLAST TO DOIF SINCE WE DON'T EXPECT ] AS LAST CHAR OF STMT.
  5446. C NO DIRECT SET OF VRBL HERE...
  5447.     RETURN
  5448. 1000    CONTINUE
  5449. C HERE JUST HAVE SOMETHING TO PASS TO CALC. DO SO.
  5450.     ILNFG=1
  5451.     LMX=LLAST-1
  5452.     DO 1001 N1=1,LMX
  5453. 1001    ILINE(N1)=LINE(N1)
  5454.     ILNCT=LMX
  5455. C PROTECT CALC FROM ANY PART OF A LINE LONGER THAN 80 CHARS (ITS MAX)
  5456.     IF(ILNCT.GT.80)ILNCT=80
  5457.     CALL CALC
  5458. C STORE EXPRESSION RESULT.
  5459. C CONVERT BETWEEN TYPES FIRST IF NEED BE
  5460.     CALL TYPGET(KDRW,KDCL,LMX)
  5461.     CALL TYPGET(27,1,N1)
  5462.     LMX=IABS(LMX)
  5463.     N1=IABS(N1)
  5464.     IF(N1.EQ.1.OR.(N1.GE.3.AND.N1.LE.8))GOTO 8739
  5465.     N1=2
  5466.     GOTO 8740
  5467. 8739    CONTINUE
  5468.     N1=4
  5469. 8740    CONTINUE
  5470. C ONLY CONCERN HERE IS REAL TYPES (CODE=2) AND INT TYPES (CODE=4)
  5471.     AACY=ACY
  5472.     IF(N1.EQ.LMX)GOTO 2670
  5473.     IF(N1.EQ.2)IIJACY=ACY
  5474.     IF(N1.EQ.4)AACY=IACY
  5475. C DO WHICHEVER CONVERSION IS NEEDED IF ONE IS NEEDED AT ALL.
  5476. 2670    CONTINUE
  5477.     CALL XVBLST(KDRW,KDCL,AACY)
  5478. C    XVBLS(KDRW,KDCL)=ACY
  5479.     RETURN
  5480.     END
  5481. c -h- dostmt.for    Fri Aug 22 13:03:55 1986    
  5482.     SUBROUTINE DOSTMT(LINE,LLAST)
  5483. C HANDLE 1 STATEMENT PARSING (DOES A BIT MORE OF THE WORK WITH THE
  5484. C PART OF THE LINE STRIPPED TO HAVE EXACTLY ONE COMMAND IN IT.
  5485.     CHARACTER*1 LINE(110)
  5486. C +++++++++++++++++++++++++++++++++++
  5487.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  5488.     EXTERNAL INDX
  5489.     INTEGER*4 VNLT
  5490.     DIMENSION FORM(128),FVLD(1,1)
  5491. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  5492. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  5493. C SO INITIALLY IGNORE.
  5494.     COMMON/FVLDC/FVLD
  5495.     InTeGer*4 RRWACT,RCLACT
  5496. C    COMMON/RCLACT/RRWACT,RCLACT
  5497.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  5498.      1  IDOL7,IDOL8
  5499. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  5500. C     1  IDOL7,IDOL8
  5501.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  5502. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5503.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5504. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5505. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  5506. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  5507.     InTeGer*4 KLVL
  5508. C    COMMON/KLVL/KLVL
  5509.     InTeGer*4 IOLVL,IGOLD
  5510. C    COMMON/IOLVL/IOLVL
  5511. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  5512. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  5513.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5514.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5515.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5516.      3  k3dfg,kcdelt,krdelt,kpag
  5517. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5518. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5519. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  5520. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5521. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5522.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  5523.     COMMON/D2R/NRDSP,NCDSP
  5524.     InTeGer*4 TYPE(1,1),VLEN(9)
  5525.     REAL*8 XVBLS(1,1)
  5526.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  5527.     INTEGER*4 JVBLS(2,1,1)
  5528.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  5529.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  5530.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  5531.     REAL*8 ACX,ACY,AACY
  5532.     INTEGER*4 IACY,IIJACY
  5533.     EQUIVALENCE(IACY,AVBLS(1,27))
  5534.     EQUIVALENCE(ACY,AVBLS(1,27))
  5535.     EQUIVALENCE(IIJACY,AACY)
  5536.     InTeGer*4 DLFG
  5537. C    COMMON/DLFG/DLFG
  5538.     InTeGer*4 KDRW,KDCL
  5539. C    COMMON/DOT/KDRW,KDCL
  5540.     InTeGer*4 DTRENA
  5541. C    COMMON/DTRCMN/DTRENA
  5542.     REAL*8 EP,PV,FV
  5543.     DIMENSION EP(20)
  5544.     INTEGER*4 KIRR
  5545. C    COMMON/ERNPER/EP,PV,FV,KIRR
  5546.     InTeGer*4 LASTOP
  5547. C    COMMON/ERROR/LASTOP
  5548.     CHARACTER*1 FMTDAT(9,76)
  5549. C    COMMON/FMTBFR/FMTDAT
  5550.     CHARACTER*1 EDNAM(16)
  5551. C    COMMON/EDNAM/EDNAM
  5552.     InTeGer*4 MFID(2),MFMOD(2)
  5553. C    COMMON/FRM/MFID,MFMOD
  5554.     InTeGer*4 JMVFG,JMVOLD
  5555. C    COMMON/FUBAR/JMVFG,JMVOLD
  5556.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  5557.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  5558. CCC    InTeGer*4 KDRW,KDCL
  5559. CCC    COMMON /DOT/KDRW,KDCL
  5560.     CHARACTER*1 ILINE(106)
  5561.     InTeGer*4 ILNFG,ILNCT
  5562.     COMMON/ILN/ILNFG,ILNCT,ILINE
  5563.  
  5564. C +++++++++++++++++++++++++++++++++++
  5565.     CALL FNAME(LINE,LLAST,INDEXF)
  5566. C ABOVE GETS FUNCTION NAMES.
  5567. C    NAME    INDEXF
  5568. C    MIN    1
  5569. C    MAX    2
  5570. C    AVG    3
  5571. C    SUM    4
  5572. C    STD    5    (STD DEVIATION)
  5573. C    IF    6    (IF STMT)
  5574. C    AND    7
  5575. C    OR    8
  5576. C    NOT    9
  5577. C    CNT    10 (COUNTS NONZERO ENTRIES)
  5578. C    NPV    11 NET PRESENT VALUE
  5579. C    LKP    12 LOOKUP IN LIST, GIVE OFFSET 0 BASED
  5580. C    LKN    13    LOOKUP NEGATIVE (INVERSE OF LKP)
  5581. C    LKE    14    LOOKUP EQUAL
  5582. C    XOR    15    EXCLUSIVE OR
  5583. C    EQV    16    EQUIVALENCE (TRUE IF BITS EQUAL)
  5584. C    MOD    17    V1 MODULO V2
  5585. C    REM    18    REMAINDER OF V1/V2
  5586. C    SGN    19    SIGN OF V1 (-1.,0., OR +1.)
  5587. C    IRR    20    INTERNAL RATE OF RETURN
  5588. C    RND    21    RANDOM NUMBER BETWEEN 0 AND 1.
  5589. C    PMT    22    PAYMENT FUNCTION
  5590. C    PVL    23    PRESENT VALUE
  5591. C    AVE    24    AVEREAGE EXCLUDING ZERO CELLS
  5592. C    CHS    25    CHOOSE
  5593. C    ATM    26    ARC TAN OF MULTIPLE ARGS (2 ARGS)
  5594. C USE  AND  TO DELIMIT FUNCTION ARGS.
  5595. C *****************************************************************************
  5596. C **** NOTE: MAX 26 IS KEPT AS A LITERAL IN NEXTEL ALSO AS FLAG THAT FUNCTION
  5597. C **** FAILED TO FIND VALID LITERAL. CHANGE THERE TOO IF YOU ADD MORE FUNCTIONS.
  5598.     IF(INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 1000
  5599. C HERE IF A FUNCTION OR AN IF STMT (FORMAT= IF varRELvarstmt|else-stmt)
  5600. C
  5601. C ALLOW CALC TO HANDLE ALL BUT IF STMTS
  5602.     IF(INDEXF.NE.6)GOTO 1000
  5603. C
  5604.     KKK=ICHAR('[')
  5605.     LLB=INDX(LINE,KKK)
  5606.     KKK=ICHAR(']')
  5607.     LRB=INDX(LINE,KKK)
  5608. C *** ERROR WITH FORMAT -- NO  SEEN IN TIME. JUST IGNORE IT.
  5609.     IF(LLB.GT.LLAST)RETURN
  5610.     IF(LRB.GT.LLAST)LRB=LLAST
  5611. C *** NOTA BENE
  5612. C NEXT STUFF COMMENTED BECAUSE WE CAN NEVER EXECUTE IT...
  5613. C    IF(INDEXF.EQ.6)GOTO 2000
  5614. CC ISOLATE MATH FUNCTIONS
  5615. C    CALL DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
  5616. CC GET % ABOVE
  5617. C    CALL TYPGET(KDRW,KDCL,TYPE(1,1))
  5618. C    IF(IABS(TYPE(1,1)).NE.2)GOTO 1760
  5619. C    CALL XVBLST(KDRW,KDCL,ACX)
  5620. CC    XVBLS(KDRW,KDCL)=ACX
  5621. CC LEAVE RESULT IN % TOO.
  5622. C    ACY=ACX
  5623. C    CALL TYPSET(27,1,TYPE(1,1))
  5624. CC    TYPE(27,1)=TYPE(KDRW,KDCL)
  5625. C    RETURN
  5626. C1760    JVBLS(1,1,1)=ACX
  5627. C    CALL JVBLST(1,KDRW,KDCL,JVBLS(1,1,1))
  5628. CC    JVBLS(1,KDRW,KDCL)=ACX
  5629. C    RETURN
  5630. 2000    CONTINUE
  5631. C HANDLE AN "IF" STATEMENT
  5632.     CALL DOIF(LINE,LLB,LRB,LLAST)
  5633. C PASS LLAST TO DOIF SINCE WE DON'T EXPECT  AS LAST CHAR OF STMT.
  5634. C NO DIRECT SET OF VRBL HERE...
  5635.     RETURN
  5636. 1000    CONTINUE
  5637. C HERE JUST HAVE SOMETHING TO PASS TO CALC. DO SO.
  5638.     ILNFG=1
  5639.     LMX=LLAST-1
  5640.     DO 1001 N1=1,LMX
  5641. 1001    ILINE(N1)=LINE(N1)
  5642.     ILNCT=LMX
  5643. C PROTECT CALC FROM ANY PART OF A LINE LONGER THAN 80 CHARS (ITS MAX)
  5644.     IF(ILNCT.GT.80)ILNCT=80
  5645.     CALL CALC
  5646. C STORE EXPRESSION RESULT.
  5647. C FIRST BE SURE STORING RIGHT TYPE
  5648.     CALL TYPGET(KDRW,KDCL,LMX)
  5649. C ONLY WORRY HERE ABOUT INTEGER VS REAL (INT=4, REAL=2 CODE)
  5650.     CALL TYPGET(27,1,N1)
  5651.     N1=IABS(N1)
  5652.     LMX=IABS(LMX)
  5653. C LET ALL DEFAULT TO TYPE 2 (FLOATING) EXCEPT EXPLICIT INTS
  5654.     IF((N1.EQ.1).OR.(N1.GE.3.AND.N1.LE.8))GOTO 2739
  5655.     N1=2
  5656.     GOTO 2740
  5657. 2739    CONTINUE
  5658.     N1=4
  5659. 2740    CONTINUE
  5660.     AACY=ACY
  5661.     IF((N1).EQ.(LMX))GOTO 2670
  5662. C TYPES DIFFER. CONVERT BETWEEN ACY AND IACY.
  5663.     IF((N1).EQ.4)AACY=IACY
  5664.     IF((N1).EQ.2)IIJACY=ACY
  5665. 2670    CONTINUE
  5666.     CALL XVBLST(KDRW,KDCL,AACY)
  5667. C    XVBLS(KDRW,KDCL)=ACY
  5668.     RETURN
  5669.     END
  5670. c -h- dspfil.for    Fri Aug 22 13:04:12 1986    
  5671.     SUBROUTINE DSPFIL(ICODE,FORM,FORM2,FVLDTP,
  5672.      1  LFTMST,LENTL,LOCOL,FILINE,LLVL,LLU,LLVLF,J)
  5673. C COPYRIGHT (C) 1983 GLENN EVERHART
  5674. C ALL RIGHTS RESERVED
  5675. C DISPLAY SPREAD SHEET ON SCREEN OR IN FILE IF ICODE=10
  5676. C USES UVT100 TO TWEAK THE VT100. NO WRAP IS ASSUMED SO
  5677. C OUTPUT UP TO 132 COLS BY 24 LINES IS OK. ONLY CHECK
  5678. C WIDTH TO ALLOW VT100 LOOKALIKES WITH MORE DISPLAY LINES TOO.
  5679. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  5680. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  5681. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  5682. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  5683. C FROM THE DISK BASED FILE HERE.
  5684. C    CHARACTER*127 CWRK
  5685. C    CHARACTER*1 CCWRK(128)
  5686.     InTeGer*4 ICODE,LFTMST
  5687. C    EQUIVALENCE(CWRK,CCWRK(1))
  5688.     InTeGer*4 LLU,LLVL,LLVLF
  5689.     InTeGer*4 RRWACT,RCLACT
  5690. C    COMMON/RCLACT/RRWACT,RCLACT
  5691.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  5692.      1  IDOL7,IDOL8
  5693. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  5694. C     1  IDOL7,IDOL8
  5695.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  5696. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5697.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5698. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5699. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  5700. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  5701.     InTeGer*4 KLVL
  5702. C    COMMON/KLVL/KLVL
  5703.     InTeGer*4 IOLVL,IGOLD
  5704. C    COMMON/IOLVL/IOLVL
  5705. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  5706. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  5707.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5708.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5709.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5710.      3  k3dfg,kcdelt,krdelt,kpag
  5711. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5712. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5713. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  5714. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  5715. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  5716.     EXTERNAL INDX
  5717.     CHARACTER*7 PRTLX
  5718.     CHARACTER*1 FORM,FVLD,CMDLIN(132),PRTLIN(132)
  5719.     EQUIVALENCE(PRTLX(1:1),PRTLIN(1))
  5720. C    INTEGER*4 VNLT
  5721.     CHARACTER*1 FVLDTP
  5722.     CHARACTER*1 LBEL(4)
  5723.     CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
  5724.     COMMON/NMSH/NMSH
  5725. C FLAG BORDR=1 IF WE WANT TO OMIT BORDERS ON DRAWING
  5726. C THE SCREEN DISPLAY TO A FILE.
  5727.     InTeGer*4 BORDR,TOMT
  5728. C COMMON ICPOS ALLOWS UVT100 ROUTINE ACCESS TO DISPLAYED NUMBERS
  5729. C FOR USES SUCH AS SETTING COLORS...
  5730.     CHARACTER*1 OARRY(100)
  5731.     InTeGer*4 OSWIT,OCNTR
  5732. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  5733. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  5734.     InTeGer*4 IPS1,IPS2,MODFLG
  5735. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  5736.        InTeGer*4 XTCFG,IPSET,XTNCNT
  5737.        CHARACTER*1 XTNCMD(80)
  5738. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  5739. C VARY FLAG ITERATION COUNT
  5740.     INTEGER KALKIT
  5741. C    COMMON/VARYIT/KALKIT
  5742.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  5743.     InTeGer*4 RCMODE,IRCE1,IRCE2
  5744. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  5745. C     1  IRCE2
  5746. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  5747. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  5748. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  5749. C RCFGX ON.
  5750. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  5751. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  5752. C  AND VM INHIBITS. (SETS TO 1).
  5753.     INTEGER*4 FH
  5754. C FILE HANDLE FOR CONSOLE I/O (RAW)
  5755. C    COMMON/CONSFH/FH
  5756.     CHARACTER*1 ARGSTR(52,4)
  5757. C    COMMON/ARGSTR/ARGSTR
  5758.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  5759.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  5760.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  5761.      3  IRCE2,FH,ARGSTR
  5762. CCC    InTeGer*4 IC1POS,IC2POS
  5763. CCC    COMMON/ICPOS/IC1POS,IC2POS
  5764.     REAL*8 XVBLS(1,1),VDSP,VCLC
  5765.     CHARACTER*1 DFE(14)
  5766.     CHARACTER*14 CDFE
  5767.     EQUIVALENCE(CDFE(1:1),DFE(1))
  5768.     DIMENSION FORM(128),FVLD(1,1)
  5769. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  5770. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  5771. C SO INITIALLY IGNORE.
  5772. C
  5773. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  5774. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  5775. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5776. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5777.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  5778.     COMMON/D2R/NRDSP,NCDSP
  5779.     InTeGer*4 ILNFG,ILNCT,RCF
  5780.     CHARACTER*1 ILINE(106)
  5781.     COMMON/ILN/ILNFG,ILNCT,ILINE
  5782.     INTEGER LENTL(5),LOCOL(5)
  5783.     CHARACTER*1 FILINE(208)
  5784. CCC    CHARACTER*1 OARRY(100)
  5785. CCC    InTeGer*4 OSWIT,OCNTR
  5786. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  5787. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  5788.     InTeGer*4 TYPE(1,1),VLEN(9)
  5789.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  5790.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  5791.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  5792. CCC    InTeGer *4 FORMFG,RCFGX
  5793. CCC    COMMON/FFGG/FORMFG,RCFGX
  5794. C
  5795. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  5796. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  5797. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  5798. C DISPLAY ACTUALLY USED FOR SCREEN.
  5799.     InTeGer*4 CWIDS(20)
  5800. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  5801. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  5802. C AS 20 NOT 75.
  5803.     REAL*8 DVS(20,75)
  5804.     INTEGER*4 LDVS(2,20,75)
  5805.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  5806.     COMMON /FVLDC/FVLD
  5807. C    CHARACTER*1 DFMTS(10,20,75)
  5808. C 10 CHARACTERS PER ENTRY.
  5809. C    COMMON/DSPCMN/DVS,DFMTS,CWIDS
  5810.     COMMON/DSPCMN/DVS,CWIDS
  5811. C THISRW,THISCL = CURRENT DISPLAYED LOCS.
  5812.     InTeGer*4 THISRW,THISCL
  5813. C NOTE ROWS ARE DOWN, COLS ACROSS INTERNALLY.
  5814. C COLUMN 2 = NUMBERS. DISPLAY COLS 2-22 WITH COL 1=TITLE
  5815. C COL 23,24 FOR COMMANDS.(23 (PARAMETER) ACTUALLY.)
  5816. C ROW OFFSET BY 6 FOR NUMBERS.
  5817. C
  5818. C MAINTAIN AN "INITIALIZED" BITMAP HERE TO USE TO AVOID GOING TO
  5819. C FVLD.
  5820. C    CHARACTER*1 IBITMP
  5821. C    DIMENSION IBITMP(2258)
  5822. C    COMMON/INITD/IBITMP
  5823. C NOTE BITMAP IS ZEROED IN SPREDSHT MAIN PROGRAM (OR AT SAVE CMD)
  5824. C AND IS SET HERE (AND HERE ONLY). ONLY USED HERE TOO...
  5825. C    character*100 fwt
  5826. C
  5827. C CODE FOR WINDOW TILING AND FILE READIN...
  5828. C &%FILENAME,NSKIP,NLEN READS FILE SKIPPING NSKIP RECS AND
  5829. C GETS NLEN RECS IN
  5830. C
  5831. C &&%FILENAME,NSKIP,NLEN JUST INSERTS FILE INTO PRINTOUT
  5832.     IF(IDOL4.EQ.0)GOTO 9880
  5833.     LFTMST=J
  5834. C NEED TO DO IT HERE...
  5835. C FORM ARRAY HAS FILE NAME INFO, IF ANY...
  5836.     KKK=ICHAR('&')
  5837.     LLA=INDX(FORM,KKK)
  5838.     IF(LLA.LE.0.OR.LLA.GT.100)GOTO 9882
  5839.     IF(FORM(LLA+1).EQ.'&')GOTO 9881
  5840. C CHECK &% FORM
  5841.     IF(FORM(LLA+1).NE.'%')GOTO 9882
  5842. C GOT &% FORM HERE.
  5843.     IF(LLVL.EQ.0.OR.LLVLF.EQ.1)GOTO 9885
  5844.     DO 9886 LNNN=1,LLVL
  5845.     LLVLN=LLVL+10
  5846.     CLOSE(LLVLN)
  5847. 9886    CONTINUE
  5848.     LLVL=0
  5849. 9885    CONTINUE
  5850.     LTST=LLA+2
  5851.     LLVLF=1
  5852. C OPEN LLVL
  5853.     CALL GETFNL(FORM(LTST),LSKIP,LLEN)
  5854.     IF(LLEN.LE.0)GOTO 9882
  5855.     LLVL=LLVL+1
  5856.     LLU=LLVL+10
  5857.     IF(LLVL.GT.4)GOTO 9931
  5858.     CALL RASSIG(LLU,FORM(LTST))
  5859.     GOTO 9930
  5860. 9931    CONTINUE
  5861.     LENTL(LLVL)=0
  5862.     LOCOL(LLVL)=0
  5863.     CLOSE(LLU)
  5864.     LLVL=LLVL-1
  5865.     LLU=LLVL+10
  5866.     GOTO 9882
  5867. 9930    CONTINUE
  5868.     LOCOL(LLVL)=LFTMST
  5869.     LENTL(LLVL)=LLEN
  5870.     IF(LSKIP.LE.0)GOTO 9906
  5871.     DO 9907 LL=1,LSKIP
  5872. 9907    READ(LLU,9889,END=9909,ERR=9909)FILINE
  5873.     DO 9910 N=1,208
  5874. 9910    FILINE(N)=CHAR(32)
  5875.     GOTO 9911
  5876. 9909    CONTINUE
  5877. C EOF SO CLOSE LUN
  5878.     LENTL(LLVL)=0
  5879.     CLOSE(LLU)
  5880.     LLVL=LLVL-1
  5881.     IF(LLVL.LE.0)GOTO 9880
  5882.     LLU=LLVL+10
  5883. 9911    CONTINUE
  5884. 9906    CONTINUE
  5885. C FILE SET UP NOW... READ IN AT 9982...
  5886. C RECORD COL # OVER FOR THIS RECURSION LEVEL
  5887.     GOTO 9882
  5888. 9881    CONTINUE
  5889. C HERE LOOK FOR && FORM. IF NONE SEEN, SKIP THIS
  5890.     IF(FORM(LLA+1).NE.'&'.OR.FORM(LLA+2).NE.'%')GOTO 9882
  5891. C HERE HAVE A FORM &&%FILE,NS,NL
  5892. C SO CLOSE OFF ALL WINDOWS IN USE AND READ IN FIRST LEVEL FILE SEEN.
  5893.     IF(LLVL.EQ.0.OR.LLVLF.EQ.2)GOTO 9884
  5894.     DO 9883 LNN=1,LLVL
  5895.     LNN1=LNN+10
  5896.     CLOSE(LNN1)
  5897. 9883    CONTINUE
  5898. C NOW ALL OPEN UNITS CLOSED
  5899.     LLVLF=2
  5900.     LLVL=0
  5901. 9884    CONTINUE
  5902.     LTST=LLA+3
  5903. C OPEN LLVL
  5904. 9937    CALL GETFNL(FORM(LTST),LSKIP,LLEN)
  5905.     IF(LLEN.LE.0)GOTO 9882
  5906.     LLVL=LLVL+1
  5907.     LLU=LLVL+10
  5908.     IF(LLVL.GT.4)GOTO 9933
  5909. C    OPEN(LLU,NAME=FORM(LTST),TYPE='OLD',
  5910. C     1  ERR=9933)
  5911.     CALL RASSIG(LLU,FORM(LTST))
  5912.     GOTO 9934
  5913. 9933    CONTINUE
  5914.     LLVL=LLVL-1
  5915.     LLU=LLVL+10
  5916.     GOTO 9882
  5917. 9934    CONTINUE
  5918.     LOCOL(LLVL)=LFTMST
  5919.     LENTL(LLVL)=LLEN
  5920.     IF(LSKIP.LE.0)GOTO 9888
  5921.     DO 9887 LL=1,LSKIP
  5922. 9887    READ(LLU,9889,ERR=9901,END=9901)FILINE
  5923. 9889    FORMAT(208A1)
  5924. C8998    FORMAT(1X,208A1)
  5925. 9898    FORMAT(132A1)
  5926.     DO 9908 N=1,208
  5927. 9908    FILINE(N)=Char(32)
  5928. C PUT IN LEADING SPACES INTO FILINE
  5929.     GOTO 9902
  5930. 9901    CONTINUE
  5931.     CLOSE(LLU)
  5932.     LLVL=LLVL-1
  5933.     IF(LLVL.LE.0)GOTO 9880
  5934.     LLU=LLVL+10
  5935. C HIT EOF ON READ, SO BACK UP A LEVEL
  5936. 9902    CONTINUE
  5937. C NOW GO AHEAD & READ... GOT PAST SKIP STUFF.
  5938. 9888    CONTINUE
  5939. C RECORD COL # OVER FOR THIS RECURSION LEVEL
  5940. 9904    IF(LENTL(LLVL).LE.0) GOTO 9901
  5941.     READ(LLU,9889,END=9901,ERR=9901)(FILINE(IV),IV=LOCOL(LLVL),208)
  5942.     LENTL(LLVL)=lentl(llvl)-1
  5943. c update lines left to read in
  5944. C LOOK FOR RECURSIVE CALLS TO DEEPER NESTED FILES TO INCLUDE
  5945.     KKK=ICHAR('&')
  5946.     LTST=INDX(FILINE,KKK)+3
  5947.     LFTMST=LTST-3
  5948. C UPDATE SO IF IT IS A CALL,WE CAN GO HANDLE IT TILL ITS EOF OR A DEEPER CALL
  5949.     IF(LTST.GT.0.AND.LTST.LT.207.AND.FILINE(LTST+1).EQ.'&'
  5950.      1  .AND.FILINE(LTST+2).EQ.'%') GOTO 9937
  5951. C WELL, NOT A DEEPER LEVEL SO JUST GO ON AND READ THIS LEVEL TILL DONE.
  5952.     IF(ICODE.EQ.10)WRITE(8,9889,ERR=9904)FILINE
  5953. c only write 80 chars on ibmpc and its ilk since they screw up on wider.
  5954.     call swrt(filine,80)
  5955. c    WRITE(0,9898,ERR=9904)(FILINE(IVV),IVV=1,132)
  5956.     GOTO 9904
  5957. 9882    CONTINUE
  5958. C HERE HANDLE OLD WINDOW READS IN PROCESS OR JUST EXIT WITHOUT DOING MUCH
  5959.     IF(LLVLF.NE.1)GOTO 9880
  5960. C ONLY HANDLE "OVERLAY" STYLE READS HERE.
  5961. C NORMAL OR-ING IN OF WINDOWS
  5962. C LOOK FOR LUN SUCH THAT J=LOCOL(LUN) INDICATING IT STARTS HERE.
  5963. C READ THIS CELL INTO IT AND FAKE OUT FVLD(1,1) TO GET IT DISPLAYED.
  5964.     IF(LLVL.LE.0)GOTO 9880
  5965.     DO 9912 N=1,LLVL
  5966.     LLM=N+10
  5967.     IF(J.EQ.LOCOL(N))GOTO 9913
  5968. 9912    CONTINUE
  5969.     GOTO 9880
  5970. 9913    CONTINUE
  5971. C NOW READ THE FILE INTO "THIS" CELL (DISPLAY PURPOSES ONLY!)
  5972. C AND FLAG FVLD
  5973.     LENTL(LLM-10)=LENTL(LLM-10)-1
  5974.     IF(LENTL(LLM-10).GT.0)
  5975.      1  READ(LLM,9889,END=9940,ERR=9940)(FORM(IV),IV=1,109)
  5976.     IF(LENTL(LLM-10).GT.0)FVLDTP=-1
  5977.     IF(LENTL(LLM-10).LT.0)GOTO 9940
  5978. C -1 FLAGS THIS AS A "TEXT" CELL DISPLAY.
  5979.     GOTO 9880
  5980. 9940    CONTINUE
  5981.     LENTL(LLM-10)=0
  5982.     LOCOL(LLM-10)=0
  5983.     CLOSE(LLM)
  5984. 9880    CONTINUE
  5985.     RETURN
  5986.     END
  5987. c -h- dspsht.f40    Fri Aug 22 13:04:12 1986    
  5988.     SUBROUTINE DSPSHT(ICODE)
  5989. C COPYRIGHT (C) 1983 GLENN EVERHART
  5990. C ALL RIGHTS RESERVED
  5991.     INCLUDE APARMS.INC
  5992. C DISPLAY SPREAD SHEET ON SCREEN OR IN FILE IF ICODE=10
  5993. C USES UVT100 TO TWEAK THE VT100. NO WRAP IS ASSUMED SO
  5994. C OUTPUT UP TO 132 COLS BY 24 LINES IS OK. ONLY CHECK
  5995. C WIDTH TO ALLOW VT100 LOOKALIKES WITH MORE DISPLAY LINES TOO.
  5996. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  5997. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  5998. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  5999. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  6000. C FROM THE DISK BASED FILE HERE.
  6001.     CHARACTER*127 CWRK
  6002.     CHARACTER*1 CCWRK(128)
  6003.     InTeGer*4 ICODE,LLU,LLVL,LLVLF
  6004.     EQUIVALENCE(CWRK(1:1),CCWRK(1))
  6005.     InTeGer*4 RRWACT,RCLACT
  6006. C    COMMON/RCLACT/RRWACT,RCLACT
  6007.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  6008.      1  IDOL7,IDOL8
  6009. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  6010. C     1  IDOL7,IDOL8
  6011.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  6012. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6013.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6014. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6015. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  6016. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  6017.     InTeGer*4 KLVL,K3DFG,KCDelt,KRDelt,kpag
  6018. C    COMMON/KLVL/KLVL
  6019.     InTeGer*4 IOLVL,IGOLD
  6020. C    COMMON/IOLVL/IOLVL
  6021. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  6022. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  6023.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  6024.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  6025.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  6026.      3  K3DFG,KCDelt,KRDelt,kpag
  6027. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  6028. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  6029. CCC    InTeGer*4 LLCMD,LLDSP
  6030. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6031. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  6032. C    EXTERNAL INDX
  6033.     CHARACTER*7 PRTLX
  6034.     CHARACTER*1 FORM,FVLD,CMDLIN(132),PRTLIN(132)
  6035.     EQUIVALENCE(PRTLX(1:1),PRTLIN(1))
  6036. C    INTEGER*4 VNLT
  6037.     CHARACTER*1 FVLDTP
  6038.     CHARACTER*1 LBEL(4)
  6039.     CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
  6040.     COMMON/NMSH/NMSH
  6041. C FLAG BORDR=1 IF WE WANT TO OMIT BORDERS ON DRAWING
  6042. C THE SCREEN DISPLAY TO A FILE.
  6043.     InTeGer*4 BORDR,TOMT
  6044. C COMMON ICPOS ALLOWS UVT100 ROUTINE ACCESS TO DISPLAYED NUMBERS
  6045. C FOR USES SUCH AS SETTING COLORS...
  6046.     CHARACTER*1 OARRY(100)
  6047.     InTeGer*4 OSWIT,OCNTR
  6048. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  6049. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  6050.     InTeGer*4 IPS1,IPS2,MODFLG
  6051. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  6052.        InTeGer*4 XTCFG,IPSET,XTNCNT
  6053.        CHARACTER*1 XTNCMD(80)
  6054. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  6055. C VARY FLAG ITERATION COUNT
  6056.     INTEGER KALKIT
  6057. C    COMMON/VARYIT/KALKIT
  6058.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  6059.     InTeGer*4 RCMODE,IRCE1,IRCE2
  6060. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  6061. C     1  IRCE2
  6062. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  6063. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  6064. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  6065. C RCFGX ON.
  6066. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  6067. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  6068. C  AND VM INHIBITS. (SETS TO 1).
  6069.     INTEGER*4 FH
  6070. C FILE HANDLE FOR CONSOLE I/O (RAW)
  6071. C    COMMON/CONSFH/FH
  6072.     CHARACTER*1 ARGSTR(52,4)
  6073. C    COMMON/ARGSTR/ARGSTR
  6074.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  6075.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  6076.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  6077.      3  IRCE2,FH,ARGSTR
  6078. CCC    InTeGer*4 IC1POS,IC2POS
  6079. CCC    COMMON/ICPOS/IC1POS,IC2POS
  6080. CCC    InTeGer*4 NULAST,LFVD
  6081. C    INTEGER*4 IOLVL
  6082. C    COMMON/IOLVL/IOLVL
  6083.     InTeGer*4 ICREF,IRREF
  6084. C    COMMON/MIRROR/ICREF,IRREF
  6085.     InTeGer*4 MODPUB,LIMODE
  6086. C    COMMON/MODPUB/MODPUB,LIMODE
  6087.     InTeGer*4 KLKC,KLKR
  6088.     REAL*8 AACP,AACQ
  6089. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  6090.     InTeGer*4 NCEL,NXINI
  6091. C    COMMON/NCEL/NCEL,NXINI
  6092.     CHARACTER*1 NAMARY(20,MROWS)
  6093. C    COMMON/NMNMNM/NAMARY
  6094.     InTeGer*4 NULAST,LFVD
  6095. C    COMMON/NULXXX/NULAST,LFVD
  6096.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  6097.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  6098. CCC    COMMON/NULXXX/NULAST,LFVD
  6099.     REAL*8 XVBLS(1,1),VDSP,VCLC
  6100.     CHARACTER*1 DFE(14)
  6101.     CHARACTER*14 CDFE
  6102.     EQUIVALENCE(CDFE(1:1),DFE(1))
  6103.     DIMENSION FORM(128),FVLD(1,1)
  6104. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  6105. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  6106. C SO INITIALLY IGNORE.
  6107. C
  6108. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  6109. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  6110. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6111. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6112.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  6113.     COMMON/D2R/NRDSP,NCDSP
  6114.     InTeGer*4 ILNFG,ILNCT,RCF
  6115.     CHARACTER*1 ILINE(106)
  6116.     COMMON/ILN/ILNFG,ILNCT,ILINE
  6117.     INTEGER LENTL(5),LOCOL(5)
  6118.     CHARACTER*1 FILINE(208)
  6119. CCC    CHARACTER*1 OARRY(100)
  6120. CCC    InTeGer*4 OSWIT,OCNTR
  6121. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  6122. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  6123.     InTeGer*4 TYPE(1,1),VLEN(9)
  6124.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  6125.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  6126.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  6127. CCC    InTeGer *4 FORMFG,RCFGX
  6128. CCC    COMMON/FFGG/FORMFG,RCFGX
  6129. C
  6130. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  6131. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  6132. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  6133. C DISPLAY ACTUALLY USED FOR SCREEN.
  6134.     InTeGer*4 CWIDS(20)
  6135. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  6136. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  6137. C AS 20 NOT 75.
  6138.     REAL*8 DVS(20,75)
  6139.     INTEGER*4 LDVS(2,20,75)
  6140.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  6141.     COMMON /FVLDC/FVLD
  6142. C    CHARACTER*1 DFMTS(10,20,75)
  6143. C 10 CHARACTERS PER ENTRY.
  6144. C    COMMON/DSPCMN/DVS,DFMTS,CWIDS
  6145.     COMMON/DSPCMN/DVS,CWIDS
  6146. C THISRW,THISCL = CURRENT DISPLAYED LOCS.
  6147.     InTeGer*4 LFTMST
  6148.     InTeGer*4 THISRW,THISCL
  6149. C NOTE ROWS ARE DOWN, COLS ACROSS INTERNALLY.
  6150. C COLUMN 2 = NUMBERS. DISPLAY COLS 2-22 WITH COL 1=TITLE
  6151. C COL 23,24 FOR COMMANDS.(23 (PARAMETER) ACTUALLY.)
  6152. C ROW OFFSET BY 6 FOR NUMBERS.
  6153. C
  6154. C MAINTAIN AN "INITIALIZED" BITMAP HERE TO USE TO AVOID GOING TO
  6155. C FVLD.
  6156. C    CHARACTER*1 IBITMP
  6157. C    DIMENSION IBITMP(2258)
  6158. C    COMMON/INITD/IBITMP
  6159. C NOTE BITMAP IS ZEROED IN SPREDSHT MAIN PROGRAM (OR AT SAVE CMD)
  6160. C AND IS SET HERE (AND HERE ONLY). ONLY USED HERE TOO...
  6161.     character*100 fwt
  6162. C    CHARACTER*1 LBITS(8)
  6163. CC    DATA LBITS/1,2,4,8,16,32,64,128/
  6164. C    LBITS(1)=1
  6165. C    LBITS(2)=2
  6166. C    LBITS(3)=4
  6167. C    LBITS(4)=8
  6168. C    LBITS(5)=16
  6169. C    LBITS(6)=32
  6170. C    LBITS(7)=64
  6171. C    LBITS(8)=128
  6172.     IF(ICODE.NE.10)GOTO 3000
  6173.     CALL UVT100(1,LLCMD,1)
  6174.     CALL UVT100(12,2,0)
  6175.     call Vwrt('Enter Print File Spec, / after to omit borders>',47)
  6176.     if(iolvl.ne.11)READ(IOLVL,26,END=8884,ERR=8884)FORM2
  6177.     if(iolvl.eq.11)call vget(form2,128)
  6178. 26    FORMAT(128A1)
  6179. C FIND SIZE OF LINE READ IN
  6180.     DO 750 N=1,128
  6181.     ISZ=129-N
  6182.     IF(FORM2(N).GT.' ')GOTO 751
  6183. 750    CONTINUE
  6184. 751    CONTINUE
  6185.     ISZ=ISZ+1
  6186.     ISZ=MIN0(127,ISZ)
  6187.     FORM2(ISZ+1)=0
  6188.     BORDR=0
  6189.     TOMT=0
  6190.     DO 4111 N=1,ISZ
  6191. C IF FILENAME HAS / AFTERWARDS, OMIT BORDER
  6192.     IF(FORM2(N).EQ.'/')BORDR=1
  6193. C NULL OUT THE / SO THAT FILENAME WILL PARSE CORRECTLY.
  6194.     IF(FORM2(N).EQ.'/')FORM2(N)=0
  6195.     IF(FORM2(N).EQ.'%')TOMT=1
  6196. 4111    CONTINUE
  6197. C    OPEN(8,FILE=FORM2,RECL=132,STATUS='NEW')
  6198.     CALL WASSIGN(8,FORM2)
  6199.     KSHEET=0
  6200.     IF(K3DFG.LE.0)GOTO 2890
  6201.     LR=NRDSP(1,1)
  6202.     LC=NCDSP(1,1)
  6203.     CALL GETSHT(LR,LC,KSHEET)
  6204.     IF(KSHEET.EQ.0)GOTO 2890
  6205.     DO 27 N=1,132
  6206. 27    PRTLIN(N)=Char(32)
  6207.     WRITE(PRTLX(1:7),1891)ksheet
  6208. c    ENCODE(7,1891,PRTLIN)KSHEET
  6209.     GOTO 3666
  6210. 2890    CONTINUE
  6211.     DO 9127 N=1,132
  6212. 9127    PRTLIN(N)=Char(32)
  6213.     WRITE(PRTLX(1:7),2)
  6214. C    ENCODE(7,2,PRTLIN)
  6215.     GOTO 3666
  6216. 3000    CONTINUE
  6217.     NULAST=-4
  6218. 3666    CONTINUE
  6219.     CALL UVT100(13,0,0)
  6220.     IF(TOMT.EQ.0.AND.ICODE.EQ.10)WRITE(8,17)NMSH
  6221.     IF(ICODE.EQ.10)GOTO 2000
  6222.     IF(ICODE.NE.2)GOTO 1000
  6223. C DRAW LABELS FIRST
  6224.     CALL UVT100(1,1,1)
  6225.     CALL UVT100(12,2,0)
  6226.     IF(ICODE.NE.10)call swrt(nmsh,80)
  6227.     CALL UVT100(1,2,1)
  6228.     CALL UVT100(12,2,0)
  6229. C ERASE TOP LINE, START AT COL 7
  6230.     KSHEET=0
  6231.     IF(K3DFG.LE.0)GOTO 1890
  6232.     LR=NRDSP(1,1)
  6233.     LC=NCDSP(1,1)
  6234.     CALL GETSHT(LR,LC,KSHEET)
  6235.     IF(KSHEET.EQ.0)GOTO 1890
  6236.     write(fwt(1:7),1891)ksheet
  6237.     call swrt(fwt,7)
  6238. c    WRITE(6,1891)KSHEET
  6239. 1891    FORMAT('PG=',I4)
  6240.     GOTO 2000
  6241. 1890    CONTINUE
  6242.     call swrt('ROW\COL',7)
  6243. 2    FORMAT('ROW\COL')
  6244. C NOTE EXACTLY 7 CHARACTERS IN FORMAT #2
  6245. 2000    CONTINUE
  6246.     J=8
  6247.     CALL UVT100(13,7,0)
  6248.     DO 1 N1=1,DRWV
  6249.     LR=NRDSP(N1,1)
  6250. C NOTE PHYS SHEET OFFSET BY 1 (SEE VARSCN)
  6251. C DISPLAY SHEET NUMBERS START AT 1
  6252.     IF(ICODE.NE.10)CALL UVT100(1,2,J)
  6253.     IF(KSHEET.GT.0.AND.LR.GE.NRDSP(1,1).AND.
  6254.      1   (LR-(KSHEET)*KCDELT).GE.1) LR=LR-(KSHEET)*KCDELT
  6255.     CALL IN2AS(LR,LBEL)
  6256.     IF(ICODE.EQ.10)GOTO 2020
  6257.     write(fwt(1:100),3)LBEL
  6258.     CALL SWRT(fwt(1:100),4)
  6259. c    WRITE(0,3)LBEL
  6260. 3    FORMAT(4A1)
  6261.     IF(LBEL(4).EQ.' '.AND.LBEL(3).EQ.' ')CALL UVT100(1,2,J+2)
  6262.     IF(LBEL(4).EQ.' '.AND.LBEL(3).NE.' ')CALL UVT100(1,2,J+3)
  6263.     write(fwt(1:100),7)n1
  6264.     call swrt(fwt(1:100),3)
  6265. 7    FORMAT('=',I2)
  6266.     GOTO 2030
  6267. 2020    CONTINUE
  6268.     IF((J+CWIDS(N1)-7).GT.121)GOTO 2030
  6269.     ICWD=MAX0(7,CWIDS(N1))
  6270.     WRITE(CWRK(1:127),2021,ERR=2030)LBEL,N1
  6271.     DO 752 N=1,ICWD
  6272.     PRTLIN(J-1+N)=CCWRK(N)
  6273. 752    CONTINUE
  6274. C    ENCODE(ICWD,2021,PRTLIN(J),ERR=2030),LBEL,N1
  6275. 2021    FORMAT(4A1,'=',I2)
  6276. 2030    CONTINUE
  6277.     J=J+CWIDS(N1)
  6278.     IF(J.GT.132)GOTO 40
  6279. 1    CONTINUE
  6280. 40    CONTINUE
  6281. C NOW COL LBLS DONE
  6282. C DO NUMBERS ACROSS LEFT.
  6283. C ONLY DO SO ON SCREEN.
  6284.     IF(BORDR.EQ.0.AND.ICODE.EQ.10)WRITE(8,18)PRTLIN
  6285.     DO 2031 KKK=1,132
  6286.     FILINE(KKK)=Char(32)
  6287. 2031    PRTLIN(KKK)=Char(32)
  6288.     IF(ICODE.EQ.10)GOTO 1000
  6289.     CALL UVT100(13,7,0)
  6290.     MCX=MIN0(LLCMD-1,DCLV)+2
  6291. C    LLVL=0
  6292. C ROWS ARE JUST OFFSET...NO MONKEY BUSINESS.
  6293.     DO 6 N1=3,MCX
  6294.     M1=N1-2
  6295.     LC=NCDSP(1,M1)-1
  6296. C N1=DISPLAY ROW
  6297.     CALL UVT100(1,N1,1)
  6298. C ADJUST DISPLAY LABELS FOR PAGE
  6299.     IF(KSHEET.GT.0.AND.LC.GE.(NCDSP(1,1)-1).AND.
  6300.      1   (LC-KSHEET*KRDELT).GE.1)LC=LC-KSHEET*KRDELT
  6301.     write(fwt(1:100),8)lc
  6302.     call swrt(fwt(1:100),6)
  6303. 8    FORMAT(I5,'>')
  6304. 6    CONTINUE
  6305. C NOW DISPLAY VALUES.
  6306. 1000    CONTINUE
  6307.     CALL UVT100(13,0,0)
  6308. C main screen display loop here.
  6309.     If (NCEL.eq.0) GOTO 1011
  6310.     DO 10 N2=1,DCLV
  6311.     JP=8
  6312.     JPL=125
  6313.     DO 110 N1=1,DRWV
  6314.     M1=NRDSP(N1,N2)
  6315.     M2=NCDSP(N1,N2)
  6316. C M1,M2 = PHYS SHEET COORDS OF WHAT IS DISPLAYED.
  6317.     M2M1=M2-1
  6318.     IF(BORDR.EQ.0.AND.ICODE.EQ.10)WRITE(PRTLX(1:7),8)M2-1
  6319. C *** OMIT DISPLAY IF FVLD=0 ***
  6320. C
  6321.     CALL FVLDGT(M1,M2,FVLD(1,1))
  6322.     IF((ICHAR(FVLD(1,1)).EQ.0).AND.ICODE.NE.2.AND.ICODE.NE.
  6323.      1  10.AND.IDOL4.EQ.0) GOTO 100
  6324. C ******************************
  6325.     VDSP=DVS(N1,N2)
  6326.     CALL XVBLGT(M1,M2,VCLC)
  6327. C    VCLC=XVBLS(M1,M2)
  6328. C SEE IF DISPLAYED AND CALCULATED NUMBERS ARE IDENTICAL.
  6329. C ONLY DISPLAY IF CHANGED.
  6330.     IF(IDOL4.NE.0)GOTO 620
  6331.     IF(VDSP.EQ.VCLC.AND.ICODE.NE.2.AND.ICODE.NE.10)GOTO 100
  6332. 620    IC1POS=M1
  6333.     IC2POS=M2
  6334. C FALL THRU HERE IF WE NEEDTO DISPLAY A NUMBER IN ROW 3+N2, COL N1
  6335. C THEN RE-ESTABLISH FORMAT, ETC.
  6336.     M23=N2+2
  6337.     J=8
  6338.     DO 11 N11=1,N1
  6339. C GET THE COORDS OF OUR CELL.
  6340. 11    J=J+CWIDS(N11)
  6341.     J=J-CWIDS(N1)
  6342. C CURRENT CHARACTER COL NUMBER IS NOW J.
  6343. C    CALL UVT100(1,M23,J)
  6344. C    IRX=(M2-1)*60+M1
  6345.     CALL REFLEC(M2,M1,IRX)
  6346. C
  6347. C GET FORMULA IN NOW
  6348.     CALL WRKFIL(IRX,CWRK(1:127),0)
  6349.     CALL CE2A(CWRK(1:127),FORM)
  6350. C CONVERT ENCODED FORMS TO REGULAR ASCII
  6351. C    READ(7'IRX)FORM
  6352. C ALLOW FOR FVLD TO HAVE CONSTANT VS FORMULA SIGNIFICANCE
  6353.     IF(JCHAR(FORM(119)).LT.-1)FORM(119)=Char(253)
  6354.     IF(JCHAR(FORM(119)).GT.1)FORM(119)=Char(3)
  6355. C
  6356. c try & omit reset here... could mess other places up.
  6357. cC FVLD VALUES OF 2 INDICATE ALREADY-COMPUTED CONSTANTS.DON'T
  6358. cC FORCE THEM TO BE REDONE. OTHERWISE DO FILL IN HOWEVER.
  6359. c    CALL FVLDGT(M1,M2,FVLD(1,1))
  6360. c    IF(ICHAR(FVLD(1,1)).NE.2)CALL FVLDST(M1,M2,FORM(119))
  6361. cC    FVLD(M1,M2)=FORM(119)
  6362. cC    IF(FORM(120).LE.0)CALL FVLDST(M1,M2,char(0))
  6363.     CALL FVLDGT(M1,M2,FVLD(1,1))
  6364.     FVLDTP=FVLD(1,1)
  6365. C HANDLE FILE INCLUSION IN SUBROUTINE...
  6366.     IF (IDOL4.NE.0)CALL DSPFIL(ICODE,FORM,FORM2,FVLDTP,LFTMST,
  6367.      1  LENTL,LOCOL,FILINE,LLVL,LLU,LLVLF,J)
  6368. C NOTE WE CALL DSPFIL SO IT CAN BE OVERLAIN AND LET THE REST
  6369. C OF DSPSHT STAY RESIDENT. (SHOULD SPEED THINGS UP MOST OF
  6370. C THE TIME)...
  6371. C THIS SETTING OF FVLD ALLOWS THE Q OPTION TO WORK.
  6372.     IF(ICHAR(FVLDTP).NE.0)CALL UVT100(1,M23,J)
  6373. 13    CONTINUE
  6374.     CALL XVBLGT(M1,M2,DVS(N1,N2))
  6375. C    DVS(N1,N2)=XVBLS(M1,M2)
  6376.     IF(ICHAR(FVLDTP).EQ.0)GOTO 100
  6377.     IF(FORMFG.LE.0.AND.JCHAR(FVLDTP).GE.0)GOTO 756
  6378.     DO 757 N=1,100
  6379. 757    FORM2(N)=FORM(N)
  6380. 756    CONTINUE
  6381. C     1  ENCODE(100,17,FORM2)(FORM(II),II=1,100)
  6382. 17    FORMAT(1X,80A1)
  6383.     IF(FORMFG.NE.0)GOTO 4321
  6384.     DO 6304 KKKK=1,9
  6385.     KKKKK=ICHAR(FORM(KKKK+119))
  6386. C    KKKKK=DFMTS(KKKK,N1,N2)
  6387. 6304    DFE(KKKK+1)=Char(MAX0(32,KKKKK))
  6388.     DFE(11)=Char(32)
  6389.     DFE(1)='('
  6390.     DFE(12)=' '
  6391. c omit any \ formats from dfe since encode fouls up with them.
  6392.     DFE(13)=' '
  6393.     DFE(14)=')'
  6394.     CALL TYPGET(M1,M2,TYPE(1,1))
  6395. c    IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
  6396. c     1  WRITE(CWRK(1:127),CDFE(1:14),ERR=4321)DVS(N1,N2)
  6397. c    IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
  6398. c     1  WRITE(CWRK(1:127),CDFE(1:14),ERR=4321)LDVS(1,N1,N2)
  6399.     IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
  6400.      1  WRITE(CWRK(1:127),DFE,ERR=4321)DVS(N1,N2)
  6401.     IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
  6402.      1  WRITE(CWRK(1:127),DFE,ERR=4321)LDVS(1,N1,N2)
  6403.     IF(JCHAR(FVLDTP).LE.0)GOTO 4321
  6404.     DO 758 N=1,100
  6405. 758    FORM2(N)=CCWRK(N)
  6406. 4321    CONTINUE
  6407.     KWID=CWIDS(N1)
  6408. C  *** FIND OUT HOW MUCH ROOM THERE IS NOW. WE KNOW WHERE WE'RE DISPLAYING, SO
  6409. C  *** ALLOW NULL CELLS TO BE SHOWN PROVIDED WE ARE:
  6410. C  1. DISPLAYING TEXT IN THE CELL, OR
  6411. C  2. IN VIEW FORMULA MODE, AND THE NEXT CELL(S) OVER ARE NULL (FVLD=0)
  6412.     IF(FORMFG.EQ.0.AND.JCHAR(FVLDTP).GE.0)GOTO 8444
  6413.     III=N1+1
  6414.     IF(III.GT.DRWV)GOTO 8446
  6415.     DO 8445 II=III,DRWV
  6416. C FOLLOW ALONG WITH THE DISPLAY'S MAPPING TO SHEET.
  6417.     IIII=NRDSP(II,N2)
  6418.     IIIII=NCDSP(II,N2)
  6419.     CALL FVLDGT(IIII,IIIII,FVLD(1,1))
  6420.     IF(ICHAR(FVLD(1,1)).NE.0)GOTO 8444
  6421.     KWID=KWID+CWIDS(II)
  6422. 8445    CONTINUE
  6423. 8446    CONTINUE
  6424. C TEST IF LAST CELL IS NULL
  6425. 8444    CONTINUE
  6426.     KWID=MIN0(KWID,JPL)
  6427. C ****** END OF MODS FOR PRINTING INTO ADJACENT NULL CELLS.
  6428.     IF(ICODE.NE.10)CALL SWRT(FORM2,KWID)
  6429.     IF(ICODE.NE.10)GOTO 100
  6430.     IF(JPL-KWID.LT.0)GOTO 115
  6431.     DO 759 II=1,KWID
  6432.     IIII=JP+II-1
  6433. 759    PRTLIN(IIII)=FORM2(II)
  6434. C    ENCODE(KWID,17,PRTLIN(JP),ERR=100)(FORM2(II),II=1,KWID)
  6435. 100    CONTINUE
  6436. 115    CONTINUE
  6437. C HERE KEEP TRACK OF AMOUNT PRINTED.
  6438.     JP=JP+CWIDS(N1)
  6439.     JPL=JPL-CWIDS(N1)
  6440. 110    CONTINUE
  6441.     IF(ICODE.NE.10)GOTO 10
  6442.     DO 634 KKKQ=1,132
  6443.     IF(ICHAR(PRTLIN(KKKQ)).LT.32)PRTLIN(KKKQ)=Char(32)
  6444. 634    CONTINUE
  6445.     WRITE(8,18)(PRTLIN(II),II=1,JP)
  6446. 18    FORMAT(1X,100A1,34A1)
  6447.     DO 19 LN1=1,132
  6448. 19    PRTLIN(LN1)=Char(32)
  6449. 10    CONTINUE
  6450. 1011    Continue
  6451.     IF(ICODE.EQ.10)CLOSE(8)
  6452.     IF(IDOL4.EQ.0)RETURN
  6453.     DO 9915 N=1,4
  6454.     LLU=N+10
  6455.     CLOSE(LLU)
  6456. 9915    CONTINUE
  6457.     LLVL=0
  6458. 8884    RETURN
  6459.     IOLVL=11
  6460.     CLOSE(3)
  6461. c    CLOSE(11)
  6462. c    OPEN(UNIT=11,FILE='CON:0/0/100/100/Analy Command')
  6463.     RETURN
  6464.     END
  6465.     SUBROUTINE GETSHT(LR,LC,KSHEET)
  6466. c FIGURE CORRECT SHEET, ENSURING THAT THE LR,LC PAIR IS
  6467. c SENSIBLY WITHIN IT.
  6468.     Include aparms.inc
  6469. c    INCLUDE 'VKLUGPRM.FTN'
  6470.     InTeGer*4 RRWACT,RCLACT
  6471. C    COMMON/RCLACT/RRWACT,RCLACT
  6472.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  6473.      1  IDOL7,IDOL8
  6474. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  6475. C     1  IDOL7,IDOL8
  6476.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  6477. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6478.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6479. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6480. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  6481. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  6482.     InTeGer*4 KLVL,K3DFG,KCDelt,KRDelt,kpag
  6483. C    COMMON/KLVL/KLVL
  6484.     InTeGer*4 IOLVL,IGOLD
  6485. C    COMMON/IOLVL/IOLVL
  6486. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  6487. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  6488.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  6489.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  6490.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  6491.      3  K3DFG,KCDelt,KRDelt,kpag
  6492.     KSHEET=0
  6493.     KK1=MRC
  6494.     KK2=MRC
  6495.     IF(KRDELT.GT.0)KK1=(LC-2)/KRDELT
  6496.     IF(KCDELT.GT.0)KK2=(LR-1)/KCDELT
  6497.     KK=MIN0(KK1,KK2)
  6498.     IF(KK.GE.(MRC-100))GOTO 222
  6499. C IF BOTH DELTAS ARE ZERO DON'T TOUCH ANYTHING.
  6500.     KSHEET=MAX0(KK,0)
  6501. C KSHEET NONZERO FLAGS WE MAKE THE MOD
  6502.     IF(LR.LT.KSHEET*KCDELT)GOTO 2220
  6503.     IF((LC-1).LT.KSHEET*KRDELT)GOTO 2220
  6504. 222    CONTINUE
  6505.     GOTO 2221
  6506. 2220    CONTINUE
  6507.     KSHEET=0
  6508. 2221    CONTINUE
  6509.     RETURN
  6510.     END
  6511. c -h- errcx.for    Fri Aug 22 13:08:07 1986    
  6512.     SUBROUTINE ERRCX (RETCD)
  6513. C COPYRIGHT (C) 1983 GLENN EVERHART
  6514. C ALL RIGHTS RESERVED
  6515. C 60=MAX REAL ROWS
  6516. C 301=MAX REAL COLS
  6517. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  6518. C VBLS AND TYPE DIMENSIONED 60,301
  6519. C **************************************************
  6520. C *                                                *
  6521. C *            SUBROUTINE ERRCX                    *
  6522. C *                                                *
  6523. C **************************************************
  6524. C
  6525. C
  6526. C THIS SUBROUTINE DOES INITIAL SYNTAX CHECKING ON THE INPUT
  6527. C LINE. THE CHECKS MAKE SURE THAT PARENTHESES ARE BALANCED
  6528. C AND THAT THE EQUAL SIGN IS NOT MISUSED.
  6529. C
  6530. C RETCD     MEANING
  6531. C
  6532. C   1        NO ERRORS DETECTED
  6533. C   2        ERROR FOUND
  6534. C
  6535. C
  6536. C
  6537. C
  6538. C   MODIFICATION CLASSES: M1
  6539. C
  6540. C
  6541. C
  6542. C
  6543. C ERRCX CALLS ERRMSG WHICH PRINTS ERROR MESSAGES.
  6544. C
  6545. C
  6546. C
  6547. C ERRCX IS CALLED BY CALC
  6548. C
  6549. C
  6550. C
  6551. C   VARIABLE       USE
  6552. C
  6553. C    ALPHA(27)    HOLDS LEGAL VARIABLE NAMES: ALPHABETIC
  6554. C                 OR THE CHARACTER %.
  6555. C    BLANK        ' '
  6556. C    I,J          HOLDS TEMPORARY VALUES.
  6557. C    LAST         HOLDS A CODE WHEN LOOKING FOR ERRORS INVOLVING
  6558. C                 THE EQUAL SIGN.
  6559. C    LEND         LAST NON-BLANK CHARACTER IN LINE(80).
  6560. C    LPAR         '('
  6561.  
  6562. C    PARCNT       0 IF PARENTHESIS ENCOUNTERED BALANCE. INCREASED
  6563. C                 BY 1 FOR EVERY LEFT PARENTHESIS, DECREASED BY
  6564. C                 BY 1 FOR EVERY RIGHT PERENTHESIS FOUND.
  6565. C    RETCD        HOLDS RETURN CODE. 1=O.K.  2=ERROR
  6566. C    RPAR         ')'
  6567. C
  6568. C
  6569. C
  6570. C    MODIFIED    REASON
  6571. C
  6572. C    18-MAY-1981    WHEN CHECKING FOR BALANCED PARENTHESIS, DON'T
  6573. C            INCLUDE THOSE THAT ARE PRECEEDED BY A SINGLE QUOTE
  6574. C            (CODE AT DO 100) (PB)
  6575. C
  6576. C
  6577. C
  6578. C    SUBROUTINE ERRCX (RETCD)
  6579.     InTeGer*4 LEVEL,NONBLK,LEND
  6580.     InTeGer*4 RETCD,PARCNT,VIEWSW,BASED
  6581.     InTeGer*4 I,J,LAST
  6582. C
  6583.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  6584.     CHARACTER*1 LINE(80)
  6585.     CHARACTER*1 QUOTE
  6586.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  6587.     COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  6588.     DATA QUOTE/''''/
  6589. C
  6590. C
  6591. C
  6592.     RETCD=1
  6593. C
  6594. C **************************************************
  6595. C ******  MAKE SURE PARENTHESIS ARE BALANCED  ******
  6596. C **************************************************
  6597. C
  6598.     PARCNT=0
  6599.     I=NONBLK
  6600. 4100    CONTINUE
  6601. C    DO 100 I=NONBLK,LEND
  6602. C SKIP VARIABLE NAMES WHICH ARE IN ENCODED FORM
  6603.     IF(ICHAR(LINE(I)).NE.255)GOTO 4101
  6604.     I=I+2
  6605.     GOTO 100
  6606. C AT 100 ADD 1 MORE TO I, SKIPPING CRUFT.
  6607. 4101    CONTINUE
  6608.     IF (LINE(I).EQ.LPAR) GOTO 50
  6609.     IF (LINE(I).EQ.RPAR) GOTO 80
  6610.     GOTO 100
  6611. C
  6612. C ENCOUNTERED A LEFT PARENTHESIS, COUNT IT ONLY IF PRECEEDING
  6613. C CHARACTER IS NOT A SINGLE QUOTE
  6614. 50    IF(I.EQ.NONBLK) GOTO 60
  6615.     IF(LINE(I-1).EQ.QUOTE) GOTO 100
  6616. 60    PARCNT=PARCNT+1
  6617.     GOTO 100
  6618. C
  6619. C ENCOUNTERED A RIGHT PARENTHESIS, COUNT IT ONLY IF PRECEEDING
  6620. C CHARACTER IS NOT A SINGLE QUOTE
  6621. 80    IF(I.EQ.NONBLK) GOTO 90
  6622.     IF(LINE(I-1).EQ.QUOTE) GOTO 100
  6623. 90    PARCNT=PARCNT-1
  6624.     IF(PARCNT.LT.0)GOTO 160
  6625. 100    CONTINUE
  6626.     I=I+1
  6627.     IF(I.LE.LEND)GOTO 4100
  6628. C
  6629.     IF (PARCNT.EQ.0) GOTO 200
  6630. C
  6631. C
  6632. C UNBALANCED PARENTHESIS
  6633.     I=6
  6634. 140    CALL ERRMSG(I)
  6635. 150    RETCD=2
  6636.     RETURN
  6637. C
  6638. C
  6639. C ILLEGAL EXPRESSION LIKE ')))X((('
  6640. 160    I=8
  6641.     GOTO 140
  6642. C
  6643. C
  6644. C **************************************************
  6645. C *********   = SIGN SYNTAX CHECK   ****************
  6646. C **************************************************
  6647. C
  6648. 200    CONTINUE
  6649. C
  6650. C
  6651. C  ALLOW A=B=C+2
  6652. C  MAY ONLY ASSIGN VALUES TO SINGLE UNSIGNED VARIABLES.
  6653. C  ALSO CATCH  =A
  6654. C       AND    A==B
  6655. C
  6656. C  LAST    =  0    FIRST CHAR OR FOUND =
  6657. C       1    1 ALPHA CHARACTER
  6658. C       2    MORE THAN 1 ALPHA OR
  6659. C        ENCOUNTERED NON-ALPHA
  6660. C        (BUT NOT = OR BLANK)
  6661. C
  6662. C
  6663.     LAST=0
  6664.     I=NONBLK
  6665. 271    CONTINUE
  6666. C    DO 270 I=NONBLK,LEND
  6667.     IF (LINE(I).EQ.BLANK) GOTO 270
  6668.     IF (LINE(I).EQ.EQ) GOTO 230
  6669. C
  6670. C
  6671. C  LOOK FOR ALPHA
  6672. C    DO 220 J=1,27
  6673. C    IF (LINE(I).EQ.ALPHA(J)) GOTO 240
  6674. C220    CONTINUE
  6675. C LOOK FOR ANY VARIABLE NAME (NOT JUST ALPHA) (GCE)
  6676.     LLND=LEND
  6677.     CALL VARSCN(LINE,I,LLND,LSTCHR,ID1,ID2,IVALID)
  6678.     IF(IVALID.EQ.0) GOTO 220
  6679.     I=LSTCHR
  6680.     IF(LSTCHR.LT.LEND)I=LSTCHR-1
  6681. C IF WE GET A GOOD VARIABLE NAME POINT AT ITS END AND GO SAY WE'RE OK.
  6682.     GOTO 240
  6683. 220    CONTINUE
  6684. C
  6685. C
  6686. C   MORE THAN 1 ALPHA OR ENCOUNTERED NON-ALPHA
  6687. C (BUT NOT = SIGN OR BLANK)
  6688. 225    LAST=2
  6689.     GOTO 270
  6690. C
  6691. C
  6692. C = SIGN ENCOUNTERED
  6693. 230    IF (LAST.EQ.1) GOTO 235
  6694. C
  6695. C ILLEGAL USE OF = SIGN
  6696.     GOTO 290
  6697. C
  6698. C HAD 1 ALPHA CHARACTER FOLLOWED BY = SIGN
  6699. 235    LAST=0
  6700.     GOTO 270
  6701. C
  6702. C ENCOUNTERED A VARIABLE NAME (1 CHARACTER)
  6703. 240    IF (LAST.EQ.2) GOTO 270
  6704.     IF (LAST.EQ.1) GOTO 225
  6705. C
  6706. C
  6707. C EXACTLY 1 ALPHA CHARACTER EITHER AS FIRST CHARACTER
  6708. C ENCOUNTERED OR AS THE 1ST CHARACTER AFTER AN = SIGN.
  6709.     LAST=1
  6710. 270    CONTINUE
  6711.     I=I+1
  6712.     IF(I.LE.LEND) GOTO 271
  6713. C *****&&&&&  SIMULATE DO LOOP TO ALLOW MONKEYING WITH INDEX INSIDE.
  6714. C WHICH IS DONE SO WE CAN HUNT FOR VARIABLES BY NAME...
  6715. C
  6716. C
  6717. C <<<<<<<<<<<< ADD ADDITIONAL CHECKS HERE >>>>>>>>>>
  6718. C
  6719.     RETURN
  6720. C
  6721. C
  6722. C ILLEGAL USE OF = SIGN
  6723. 290    I=17
  6724.     GO TO 140
  6725.     END
  6726. c -h- errmsg.for    Fri Aug 22 13:08:07 1986    
  6727.     SUBROUTINE ERRMSG (IMSG)
  6728. C COPYRIGHT (C) 1983 GLENN EVERHART
  6729. C ALL RIGHTS RESERVED
  6730. C 60=MAX REAL ROWS
  6731. C 301=MAX REAL COLS
  6732. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  6733. C VBLS AND TYPE DIMENSIONED 60,301
  6734. C **************************************************
  6735. C *                                                *
  6736. C *       SUBROUTINE  ERRMSG(MSG)                  *
  6737. C *                                                *
  6738. C **************************************************
  6739. C
  6740. C
  6741. C PRINTS OUT ERROR MESSAGES AS REQUESTED BY CODE IN MSG.
  6742. C
  6743. C ERRMSG IS CALLED BY THE FOLLOWING ROUTINES:
  6744. C
  6745. C AT
  6746. C BASCNG
  6747. C CALBIN
  6748. C CALC
  6749. C CALUN
  6750. C CMND
  6751. C CONTYP
  6752. C DECLR
  6753. C ERRCX
  6754. C INPOST
  6755. C MULADD
  6756. C MULDIV
  6757. C MULMUL
  6758. C NEXTEL
  6759. C POSTVL
  6760. C VAROUT
  6761. C ZNEG
  6762. C
  6763. C
  6764. C    VARIABLE    USE
  6765. C
  6766. C   I         TEMPORARY VARIABLE TO AVOID SIDE-EFFECT WITH CALLS
  6767. C             THAT USE A CONSTANT FOR THE ARGUMENT.
  6768. C   MSG       ERROR MESSAGE CODE.
  6769. C
  6770. C
  6771. C
  6772. C  NOTE: USE CODE 25 FOR UNKNOWN CAUSES.
  6773. C
  6774. C
  6775. C
  6776. C    SUBROUTINE ERRMSG (MSG)
  6777. C
  6778.     InTeGer*4 IMSG,I
  6779.     CHARACTER*20 MSG(27)
  6780.     CHARACTER*8 EMSG
  6781.     DATA EMSG/'*ERROR* '/
  6782.     DATA MSG(1)/'1ST CHAR ILLEGAL   '/
  6783.     DATA MSG(2)/'INDIR.NEST OVFLOW  '/
  6784.     DATA MSG(3)/'UNIDENTIFIED CMND  '/
  6785.     DATA MSG(4)/'ILL CHR IN VBL LIST'/
  6786.     DATA MSG(5)/'VBLS NT SEP W/COMMA'/
  6787.     DATA MSG(6)/'UNBAL PARENTHESIS  '/
  6788.     DATA MSG(7)/'STACK 1 OVERFLOW   '/
  6789.     DATA MSG(8)/'ILLEGAL EXPRESSION '/
  6790.     DATA MSG(9)/'STACK 2 OVERFLOW   '/
  6791.     DATA MSG(10)/'FCN ILL W/INT ARGS '/
  6792.     DATA MSG(11)/'FCN ILL W/MPR ARGS '/
  6793.     DATA MSG(12)/'FCN ILL W/ASCI ARG '/
  6794.     DATA MSG(13)/'FCN ILL W/REAL ARG '/
  6795.     DATA MSG(14)/'SQRT OF NEG NUMBER '/
  6796.     DATA MSG(15)/'MP EXP W/NEG POWER '/
  6797.     DATA MSG(16)/'UNDEFINED VARIABLE '/
  6798.     DATA MSG(17)/'ILL USE OF = SIGN  '/
  6799.     DATA MSG(18)/'UNIDENTIFIED FUNCT '/
  6800.     DATA MSG(19)/'ILLEGAL BASE SPEC  '/
  6801.     DATA MSG(20)/'ILLEGAL CHARACTER  '/
  6802.     DATA MSG(21)/'. OK ONLY W/BASE 10'/
  6803.     DATA MSG(22)/'OVER 19 DIGIT MP NO'/
  6804.     DATA MSG(23)/'DIVIDE BY ZERO ERR '/
  6805.     DATA MSG(24)/'ILL REAL EXP FIELD '/
  6806.     DATA MSG(25)/'WEIRD BUG. CALL GE.'/
  6807.     DATA MSG(26)/'ILLEG CONVERSION   '/
  6808.     DATA MSG(27)/'READ ERROR         '/
  6809. C
  6810. C
  6811.     CALL UVT100(1,1,10)
  6812. C WRITE "*ERROR*" FOLLOWED BY MESSAGE TEXT/
  6813.     CALL SWRT(EMSG,8)
  6814.     I=IMSG
  6815.     IF(I.LE.0.OR.I.GT.27)I=25
  6816.     CALL SWRT(MSG(I),20)
  6817. C
  6818. 99    RETURN
  6819.     END
  6820. c -h- flip.for    Fri Aug 22 13:09:05 1986    
  6821.     SUBROUTINE FLIP (VEC,SIZE,PT)
  6822. C COPYRIGHT (C) 1983 GLENN EVERHART
  6823. C ALL RIGHTS RESERVED
  6824. C 60=MAX REAL ROWS
  6825. C 301=MAX REAL COLS
  6826. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  6827. C VBLS AND TYPE DIMENSIONED 60,301
  6828. C **************************************************
  6829. C *                                                *
  6830. C *         SUBROUTINE FLIP(VEC,SIZE,PT)           *
  6831. C *                                                *
  6832. C **************************************************
  6833. C
  6834. C
  6835. C  FLIPS THE NON-ZERO DIGITS UP TO PT IN VECTOR VEC IN REVERSE
  6836. C  ORDER.  USED TO PLACE NUMBERS IN PROPER ORDER INTO VBLS THAT
  6837. C  HAVE BEEN READ IN HIGH ORDER FIRST.
  6838. C
  6839. C FLIP IS CALLED BY NEXTEL
  6840. C
  6841. C   VARIABLE   USE
  6842. C
  6843. C     H1     TEMPORARILY HOLDS A CHARACTER*1 VALUE
  6844. C     I      INDEXES DIGITS THAT ARE FLIPPED.
  6845. C     K      THE MIDPOINT OF THE FLIPPING ACTION.
  6846. C     PT     HOLDS THE RANGE OF THE FLIPPING ACTION.
  6847. C            (USUALLY THE HIGH ORDER NON-ZERO DIGIT)
  6848. C
  6849. C
  6850. C
  6851. C    SUBROUTINE FLIP (VEC,SIZE,PT)
  6852. C
  6853. C
  6854.     InTeGer*4 SIZE,PT
  6855.     InTeGer*4 K
  6856. C
  6857.     CHARACTER*1 VEC(SIZE), H1
  6858. C
  6859. C
  6860.     K=PT/2
  6861.     IF (K.EQ.0) GOTO 20
  6862.     DO 10 I=1,K
  6863.     H1=VEC(I)
  6864.     VEC(I)=VEC(PT+1-I)
  6865. 10    VEC(PT+1-I)=H1
  6866. 20    RETURN
  6867.     END
  6868. c -h- fname.fms    Fri Aug 22 13:09:16 1986    
  6869.     SUBROUTINE FNAME(LINE,LLAST,INDEXF)
  6870. C RETURN FUNCTION NAME IF ANY
  6871. C IMPLEMENT CODE RECOGNITION ALSO...
  6872. C CODES 230-254 ARE THE FUNCTION NAMES... REPLACE THE 3 BYTES BY 1
  6873. C CODE BYTE TO IMPLEMENT...
  6874. C
  6875.     CHARACTER*1 LINE(110)
  6876. c    EXTERNAL INDX
  6877.     INTEGER*4 FNAM(26)
  6878.     character*4 fnmx(26)
  6879.     equivalence(fnmx(1)(1:1),fnam(1))
  6880.     CHARACTER*1 FCHNM(4,26)
  6881.     EQUIVALENCE(FNAM(1),FCHNM(1,1))
  6882.     DATA FNMX/'MIN ','MAX ','AVG ','SUM ','STD ','IF  ',
  6883.      1  'AND ','IOR ','NOT ','CNT ','NPV ','LKP ',
  6884.      2  'LKN ','LKE ','XOR ','EQV ','MOD ','REM ','SGN ','IRR ',
  6885.      3  'RND ','PMT','PVL','AVE','CHS','ATM'/
  6886.     INDEXF=0
  6887.     N1=ICHAR(LINE(1))
  6888. C RECOGNIZE ENCODED VARIABLE NAMES.
  6889.     IF(N1.LT.230.OR.N1.GT.254)GOTO 3000
  6890.     INDEXF=N1-229
  6891.     RETURN
  6892. 3000    CONTINUE
  6893.     DO 1 N1=1,26
  6894.     DO 2 N2=1,3
  6895.     IF(LINE(N2).NE.FCHNM(N2,N1))GOTO 1
  6896. 2    CONTINUE
  6897. C IF WE FALL THROUGH, WE HAVE A VALID FCN NAME INDEX IN INDEXF
  6898.     INDEXF=N1
  6899.     GOTO 3
  6900. 1    CONTINUE
  6901. 3    CONTINUE
  6902.     RETURN
  6903.     END
  6904. c -h- frmedt.ftn    Fri Aug 22 13:09:29 1986    
  6905.     SUBROUTINE FRMEDT(INLIN,LEND)
  6906. C COPYRIGHT 1984 GLENN AND MARY EVERHART
  6907. C ALL RIGHTS RESERVED
  6908. C FORMULA EDIT TO FIND AND EDIT FORMULAS OF FORM
  6909. C    {VAR
  6910. C AND REPLACE THE VARIABLE SPEC BY FORMULA FOR THAT VARIABLE
  6911.     INCLUDE APARMS.INC
  6912.     CHARACTER*1 INLIN(110),WRK1(120),WRK2(128)
  6913.     CHARACTER*3 WRK13
  6914.     EQUIVALENCE(WRK13(1:1),WRK1(23))
  6915.     InTeGer*4 RRWACT,RCLACT
  6916. C    COMMON/RCLACT/RRWACT,RCLACT
  6917.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  6918.      1  IDOL7,IDOL8
  6919. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  6920. C     1  IDOL7,IDOL8
  6921.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  6922. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6923.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6924. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6925. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  6926. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  6927.     InTeGer*4 KLVL
  6928. C    COMMON/KLVL/KLVL
  6929.     InTeGer*4 IOLVL,IGOLD
  6930. C    COMMON/IOLVL/IOLVL
  6931. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  6932. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  6933.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  6934.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  6935.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  6936.      3  k3dfg,kcdelt,krdelt,kpag
  6937. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  6938. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  6939. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  6940. CCC    InTeGer*4 LLCMD,LLDSP
  6941. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6942. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  6943. C ADD LOGICAL NAMES IN THE FOLLOWING FASHION, TO BE MANIPULATED
  6944. C HERE ALONE:
  6945. C
  6946. C STORE LOGICAL NAMES, UP TO 16 CHARS, HERE IN AN ARRAY WITH
  6947. C DESIRED ID1,ID2 VALUES OF CELLS TO LOAD. WHERE A {NAME IS SEEN,
  6948. C REPLACE WITH DESIRED CELL ADDRESS.
  6949. C  TO DEFINE LOGICAL NAMES, LOOK FOR = AFTER A NAME. IF = IS SEEN
  6950. C  AFTER THE { CHARACTER, ASSUME IT'S A LINE OF FORM {SALES=AA0
  6951. C  (OR {SALES=00 TO DEASSIGN) AND STORE THE NAME. UP TO THE USER
  6952. C  TO PUT THE DESIRED FORMULA IN AS HE LIKES. MAY USE A TEST STMT
  6953. C  IF DESIRED.
  6954. CCC    CHARACTER*1 NAMARY(20,301)
  6955. C ALLOW AS MANY NAMES AS THERE ARE ROWS... ARBITRARY...
  6956.     InTeGer*4 ICREF,IRREF
  6957. C    COMMON/MIRROR/ICREF,IRREF
  6958.     InTeGer*4 MODPUB,LIMODE
  6959. C    COMMON/MODPUB/MODPUB,LIMODE
  6960.     InTeGer*4 KLKC,KLKR
  6961.     REAL*8 AACP,AACQ
  6962. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  6963.     InTeGer*4 NCEL,NXINI
  6964. C    COMMON/NCEL/NCEL,NXINI
  6965.     CHARACTER*1 NAMARY(20,MROWS)
  6966. C    COMMON/NMNMNM/NAMARY
  6967.     InTeGer*4 NULAST,LFVD
  6968. C    COMMON/NULXXX/NULAST,LFVD
  6969.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  6970.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  6971.     InTeGer*2 NAMNUM(10,MROWS)
  6972.     EQUIVALENCE(NAMARY(1,1),NAMNUM(1,1))
  6973. CCC    COMMON/NMNMNM/NAMARY
  6974. C NAMNUM(9,RCL) AND NAMNUM(10,RCL) ARE RRW AND RCL
  6975. C STORAGE. NAMARY(1-18,RCL) STORES NAME ASCII TEXT (POSSIBLY
  6976. C NULL TERMINATED). FIND CELLS VIA LINEAR SEARCH.
  6977.     SAVE NAMMAX
  6978.     InTeGer*4 NAMMAX
  6979. C NAMMAX IS MAX DIM OF NAMARY THAT'S FILLED IN.
  6980.     EXTERNAL INDX
  6981.     InTeGer*4 LEND
  6982.     DATA NAMMAX/0/
  6983.     LCNT=0
  6984. 1000    IF(LCNT.GT.20)RETURN
  6985.     KKK=ICHAR('{')
  6986.     I1=INDX(INLIN,KKK)
  6987.     IF(I1.LE.0.OR.I1.GT.70)RETURN
  6988. C ONLY ALLOW IF THERE IS A { CHAR THERE
  6989.     IF(INLIN(I1).NE.'{')RETURN
  6990.     KKK=ICHAR('=')
  6991.     I2=INDX(INLIN,KKK)
  6992.     IF(I2.LE.0.OR.I2.LT.I1.OR.I2.GT.70.OR.INLIN(I2)
  6993.      1  .NE.'=')GOTO 5400
  6994.     IF((I2-I1).LE.1)GOTO 5400
  6995. C HERE SEE AN = SIGN AFTER A {VAR STRING. ATTEMPT TO EVALUATE.
  6996. C GUARANTEED AT LEAST 1 CHARACTER OF NAME.
  6997.     I3=MIN0((I2-I1-1),16)
  6998. c check if * seen ( text would then be  {*= ) for printout
  6999.  
  7000. c of symbol table
  7001.     IF(INLIN(I1+1).NE.'*')GOTO 5600
  7002.     IF(NAMMAX.LE.0)GOTO 5600
  7003.     CALL UVT100(1,LLCMD,1)
  7004.     CALL UVT100(12,2,0)
  7005. C ERASE LINE
  7006.     CALL VWRT('Output File:',12)
  7007.     call vget(wrk1,80)
  7008. c    read(11,5602,end=5419,err=5419)(wrk1(II),II=1,80)
  7009. 5602    format(80a1)
  7010.     DO 5603 N=1,79
  7011.     NN=80-N
  7012.     IF(JCHAR(WRK1(NN)).GT.32)GOTO 5604
  7013.     WRK1(NN)=Char(0)
  7014. 5603    CONTINUE
  7015. 5604    CONTINUE
  7016.     close(8)
  7017.     CALL WASSIG(8,WRK1)
  7018. C OPEN OUTPUT FOR WRITE
  7019. C THEN DUMP SYMBOLS THERE
  7020. C SYMBOL TABLE DUMP CAN BE SAVED ANYWHERE AND REENTERED AS
  7021. C ASSIGNMENT STMTS.
  7022.     WRK1(1)='{'
  7023.     DO 5607 N=2,110
  7024. 5607    WRK1(N)=0
  7025.     WRK1(18)='='
  7026.     DO 5605 N=1,NAMMAX
  7027.     IF(NAMNUM(9,N)+NAMNUM(10,N).LE.0)GOTO 5605
  7028.     DO 5608 NN=1,16
  7029. 5608    WRK1(NN+1)=NAMARY(NN,N)
  7030.     CALL IN2AS(KK,WRK1(19))
  7031.     NAMNUM(9,N)=KK
  7032.     WRITE(WRK13(1:3),5606,ERR=5419)NAMNUM(10,N)-1
  7033. C    ENCODE(3,5606,WRK1(23))NAMNUM(10,N)-1
  7034. 5606    FORMAT(I3)
  7035.     K=3
  7036.     WRK2(1)='T'
  7037.     WRK2(2)='E'
  7038.     WRK2(3)=' '
  7039.     DO 5609 KK=1,106
  7040.     I4=JCHAR(WRK1(KK))
  7041.     IF(I4.LE.32)GOTO 5609
  7042.     K=K+1
  7043.     WRK2(K)=CHAR(I4)
  7044. 5609    CONTINUE
  7045. C WRITE OUT DEFINITIONS AS IF THEY WERE ASSIGMNENT STMTS.
  7046.     WRITE(8,5610)(WRK2(KK),KK=1,K)
  7047. 5610    FORMAT(110A1)
  7048. 5605    CONTINUE
  7049.     CLOSE(8)
  7050.     GOTO 5419
  7051. 5600    CONTINUE
  7052.     LO=I2+1
  7053.     IHI=LO+25
  7054.     CALL VARSCN(INLIN,LO,IHI,LSTCHR,ID1,ID2,IVLD)
  7055. C IF IVLD=0 ASSUME WE'RE UNDEFINING THE SYMBOL
  7056.     IF(IVLD.GT.0)GOTO 5402
  7057. C INVALID SYMBOL. UNDEFINE THE STRING.
  7058.     DO 5403 I4=1,NAMMAX
  7059.     DO 5404 I5=1,I3
  7060. C REQUIRE WHOLE STRING FOR SEARCH.
  7061.     IF(INLIN(I1+I5).NE.NAMARY(I5,I4))GOTO 5403
  7062. 5404    CONTINUE
  7063. C GOT IT IF WE FALL THRU
  7064.     NAMNUM(9,I4)=0
  7065.     NAMNUM(10,I4)=0
  7066. C ZERO THE ELEMENT DEFINITION AND FORGET IT...
  7067.     DO 5432 I5=1,16
  7068. 5432    NAMARY(I5,I4)=Char(0)
  7069. 5403    CONTINUE
  7070.     GOTO 5419
  7071. 5402    CONTINUE
  7072. C VALID ARRAY ELEMENT, DEFINE IT.
  7073.     IF(NAMMAX.LE.0)GOTO 5406
  7074.     DO 5405 I4=1,NAMMAX
  7075.     IF(NAMNUM(9,I4)+NAMNUM(10,I4).EQ.0)GOTO 5410
  7076. 5405    CONTINUE
  7077.     GOTO 5406
  7078. 5410    CONTINUE
  7079. C GOT IT IF WE FALL THRU
  7080.     NAMNUM(9,I4)=ID1
  7081.     NAMNUM(10,I4)=ID2
  7082. C ZERO THE ELEMENT DEFINITION AND FORGET IT...
  7083.     GOTO 5407
  7084. 5406    CONTINUE
  7085.     IF(NAMMAX.LT.0)NAMMAX=0
  7086.     NAMMAX=MIN0(NAMMAX+1,MROWS)
  7087.     NAMNUM(9,NAMMAX)=ID1
  7088.     NAMNUM(10,NAMMAX)=ID2
  7089. C NOW SAVE THE SYMBOL NAME
  7090.     I4=NAMMAX
  7091. 5407    CONTINUE
  7092.     DO 5409 I5=1,16
  7093. 5409    NAMARY(I5,I4)=0
  7094.     DO 5408 I5=1,I3
  7095.     NAMARY(I5,I4)=INLIN(I1+I5)
  7096. 5408    CONTINUE
  7097. C NO FURTHER PROCESSING IF WE DID ANY DEFINITION... JUST EXIT
  7098. 5419    CONTINUE
  7099.     INLIN(1)='%'
  7100. C IF A DEFINITION, JUST PUT SOMETHING INNOCUOUS INTO LINE FOR
  7101. C LATER PROCESSING.
  7102.     DO 5421 I5=2,110
  7103. 5421    INLIN(I5)=0
  7104.     RETURN
  7105. 5400    CONTINUE
  7106. C NOW THAT DEFINITIONS ARE TAKEN CARE OF (IF ANY)
  7107. C HANDLE SYMBOLIC SEARCHES
  7108.     if(nammax.le.0)goto 5505
  7109.     LSTCHR=I1+1
  7110.     DO 5501 I4=1,NAMMAX
  7111.     DO 5502 I5=1,16
  7112.     IF(JCHAR(NAMARY(I5,I4)).LE.47)GOTO 5502
  7113.     IF(JCHAR(INLIN(I1+I5)).LE.47)GOTO 5502
  7114.     LSTCHR=I1+I5+1
  7115.     IF(INLIN(I1+I5).NE.NAMARY(I5,I4))GOTO 5501
  7116. CC SKIP OUT IF WE HAVE A TERMINATING CHARACTER IN DEF
  7117. CC AND HAD AT LEAST 1 NONTERMINATING CHAR IN DEFINITION.
  7118. C    IF(JCHAR(NAMARY(1,I4)).GT.47.AND.
  7119. C     1     JCHAR(NAMARY(I5,I4)).LE.47) GOTO 5560
  7120. 5502    CONTINUE
  7121. 5560    CONTINUE
  7122. C IF WE FALL THRU WE HAVE A MATCH
  7123.     ID1=NAMNUM(9,I4)
  7124.     ID2=NAMNUM(10,I4)
  7125. C LAST CHECK: BE SURE WE AREN'T GIVING A DELETED SYMBOL.
  7126.     IF((ID1+ID2).GT.0)GOTO 5500
  7127. 5501    CONTINUE
  7128. 5505    continue
  7129.     LO=I1+1
  7130.     IHI=LO+25
  7131.     CALL VARSCN(INLIN,LO,IHI,LSTCHR,ID1,ID2,IVLD)
  7132.     IF(IVLD.LE.0)RETURN
  7133. 5500    CONTINUE
  7134.     DO 11 N1=1,120
  7135. 11    WRK1(N1)=0
  7136. C HERE HAVE A VALID CONSTRUCT SO REPLACE IT
  7137. C (ONLY ONE PER LINE THIS TIME ROUND)
  7138. C    IRX=(ID2-1)*60+ID1
  7139.     CALL REFLEC(ID2,ID1,IRX)
  7140. C COPY FIRST PART OF FORMULA TO WORK ARRAY
  7141.     LO=I1-1
  7142.     IHI=0
  7143.     IF(LO.LE.0)GOTO 10
  7144.     DO 1 N1=1,LO
  7145.     IHI=N1
  7146.     WRK1(IHI)=INLIN(N1)
  7147. 1    CONTINUE
  7148. 10    CONTINUE
  7149.     IHI=IHI+1
  7150.     CALL WRKFIL(IRX,WRK2,0)
  7151. C WRKFIL READS THE FORMULA INTO WRK2. NEXT FIND END OF TEXT
  7152.     DO 2 N1=1,110
  7153.     LO=111-N1
  7154.     IF(ICHAR(WRK2(LO)).GT.32)GOTO 3
  7155. 2    CONTINUE
  7156. 3    CONTINUE
  7157. C LO NOW IS LENGTH OF FORMULA
  7158.     DO 4 N1=1,LO
  7159.     WRK1(IHI)=WRK2(N1)
  7160.     IF(IHI.LT.110)IHI=IHI+1
  7161. 4    CONTINUE
  7162. C TACK ON ANY MORE TEXT
  7163. C RELY ON INLIN BEING 110 CHARS LONG
  7164.     DO 5 N1=LSTCHR,110
  7165.     WRK1(IHI)=INLIN(N1)
  7166.     IF(IHI.LT.110)IHI=IHI+1
  7167. 5    CONTINUE
  7168. C NOW COPY 110 CHARS BACK TO INLIN
  7169.     DO 6 N1=1,110
  7170. 6    INLIN(N1)=WRK1(N1)
  7171.     DO 7 N1=1,110
  7172.     LO=111-N1
  7173.     IF(ICHAR(INLIN(LO)).GT.32)GOTO 8
  7174. C    INLIN(LO)=CHAR(32)
  7175. 7    CONTINUE
  7176. 8    LEND=LO
  7177.     LCNT=LCNT+1
  7178.     GOTO 1000
  7179. C KEEP LOOKING & RECURSING BUT IMPOSE LIMIT
  7180. C    RETURN
  7181.     END
  7182. c -h- fvldgt.for    Fri Aug 22 13:10:38 1986    
  7183.         SUBROUTINE FVLDGT(ID1,ID2,IVAL)
  7184. C
  7185. C FVLDGT - RETURN FVLD BYTE GIVEN 2 DIMS OF ITS "LOCATION"
  7186.     INCLUDE APARMS.INC
  7187.         InTeGer*4 ID1,ID2
  7188.         CHARACTER*1 IVAL
  7189. C NEXT BITMAPS IMPLEMENT FVLD
  7190.     EXTERNAL INDX
  7191.         CHARACTER*1 LBITS(8)
  7192.         COMMON/BITS/LBITS
  7193.         CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
  7194.     CHARACTER*1 FVXX(Imps3)
  7195.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  7196.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  7197.         Common/FVLDM/FVXX
  7198. c        COMMON/FVLDM/FV1,FV2,FV4
  7199. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  7200. C TYPES OF AC'S STORAGE:
  7201.         CHARACTER*1 ITYP(Imp1s)
  7202.         InTeGer*4 IATYP(27)
  7203.         COMMON/TYP/IATYP,ITYP
  7204.     InTeGer*4 ICREF,IRREF
  7205. C    COMMON/MIRROR/ICREF,IRREF
  7206.     InTeGer*4 MODPUB,LIMODE
  7207. C    COMMON/MODPUB/MODPUB,LIMODE
  7208.     InTeGer*4 KLKC,KLKR
  7209.     REAL*8 AACP,AACQ
  7210. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  7211.     InTeGer*4 NCEL,NXINI
  7212. C    COMMON/NCEL/NCEL,NXINI
  7213.     CHARACTER*1 NAMARY(20,Mrows)
  7214. C    COMMON/NMNMNM/NAMARY
  7215.     InTeGer*4 NULAST,LFVD
  7216. C    COMMON/NULXXX/NULAST,LFVD
  7217.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  7218.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  7219. CCC    InTeGer*4 ICREF,IRREF
  7220. CCC    COMMON/MIRROR/ICREF,IRREF
  7221. C
  7222. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  7223. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  7224. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  7225. C AREAS WITH DATA.
  7226.     InTeGer*4 DLFG
  7227. C    COMMON/DLFG/DLFG
  7228.     InTeGer*4 KDRW,KDCL
  7229. C    COMMON/DOT/KDRW,KDCL
  7230.     InTeGer*4 DTRENA
  7231. C    COMMON/DTRCMN/DTRENA
  7232.     REAL*8 EP,PV,FV
  7233.     DIMENSION EP(20)
  7234.     INTEGER*4 KIRR
  7235. C    COMMON/ERNPER/EP,PV,FV,KIRR
  7236.     InTeGer*4 LASTOP
  7237. C    COMMON/ERROR/LASTOP
  7238.     CHARACTER*1 FMTDAT(9,76)
  7239. C    COMMON/FMTBFR/FMTDAT
  7240.     CHARACTER*1 EDNAM(16)
  7241. C    COMMON/EDNAM/EDNAM
  7242.     InTeGer*4 MFID(2),MFMOD(2)
  7243. C    COMMON/FRM/MFID,MFMOD
  7244.     InTeGer*4 JMVFG,JMVOLD
  7245. C    COMMON/FUBAR/JMVFG,JMVOLD
  7246.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  7247.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  7248. CCC        CHARACTER*1 FMTDAT(9,76)
  7249. CCC        COMMON/FMTBFR/FMTDAT
  7250.         CHARACTER*1 I1,I2,I4
  7251.     CHARACTER*1 IT1,IT2,IT4,IT8
  7252.     LOGICAL*4 LT1,LT2,LT4,LT8
  7253.     InTeGer*4 KT1,KT2,KT4,KT8
  7254.     CHARACTER*1 IT12(2),IT22(2),IT42(2),IT82(2)
  7255.        EQUIVALENCE(LT1,IT12(1)),(LT2,IT22(1)),(LT4,IT42(1)),
  7256.      1(LT8,IT82(1))
  7257.        EQUIVALENCE(KT1,IT12(1)),(KT2,IT22(1)),(KT4,IT42(1)),
  7258.      1 (KT8,IT82(1))
  7259. C INTEL 8088 USES 1ST CHAR IN HIGH BYTE SO FORCE IT1, IT2, IT4 ETC TO LOW
  7260. C ORDER BYTE WITH EQUIVALENCES
  7261.     EQUIVALENCE(IT12(2),IT1),(IT22(2),IT2),(IT42(2),IT4),
  7262.      1 (IT82(2),IT8)
  7263.     IF(ID2.GT.0)GOTO 2000
  7264. C TRICK ENTRY USING ID IN FIRST ARG, 0 IN 2ND ARG...
  7265. C TELL XVBLST/XVBLGT ABOUT FV4 STATE (SET BY CALL WITH -4 BYTE ON FVLDST)
  7266.     ID=ID1
  7267.         IBT=((ID-1)/8)+1
  7268.     KT1=ID-1
  7269.     KT2=7
  7270.     KT1=IMASK(KT1,KT2)
  7271. C    LT1=LT1.AND.LT2
  7272.     IBIT=KT1+1
  7273. C        IBIT=((ID-1).AND.7)+1
  7274. C        I1=FV1(IBT).AND.LBITS(IBIT)
  7275. C        I2=FV2(IBT).AND.LBITS(IBIT)
  7276. C        I4=FV4(IBT).AND.LBITS(IBIT)
  7277.     KT1=ICHAR(FV1(IBT))
  7278.     KT2=ICHAR(FV2(IBT))
  7279.     KT4=ICHAR(FV4(IBT))
  7280.     KT8=ICHAR(LBITS(IBIT))
  7281.     KT1=IMASK(KT1,KT8)
  7282. C    LT1=LT1.AND.LT8
  7283.     KT2=IMASK(KT2,KT8)
  7284. C    LT2=LT2.AND.LT8
  7285.     KT4=IMASK(KT4,KT8)
  7286. C    LT4=LT4.AND.LT8
  7287.     I1=CHAR(KT1)
  7288.     I2=CHAR(KT2)
  7289.     I4=CHAR(KT4)
  7290.     IVAL=0
  7291. C RETURN NONZERO IF ANY BITS ARE SET.
  7292.     IF((KT1+KT2+KT4).NE.0)IVAL=1
  7293. C    IF((I1+I2+I4).NE.0)IVAL=1
  7294.     RETURN
  7295. 2000    CONTINUE
  7296. C REFLECT ALL BACK TO PRIME STORAGE REGION
  7297. C        ID=(ID2-1)*60+ID1
  7298.     IF(ID2.EQ.1.AND.ID1.LE.MRC)GOTO 7806
  7299.     CALL REFLEC(ID2,ID1,ID)
  7300.     GOTO 7807
  7301. 7806    CONTINUE
  7302.     ID=ID1
  7303. 7807    IBT=((ID-1)/8)+1
  7304.     KT1=ID-1
  7305.     KT2=7
  7306.     KT1=IMASK(KT1,KT2)
  7307. C    LT1=LT1.AND.LT2
  7308.     IBIT=KT1+1
  7309. C        IBIT=((ID-1).AND.7)+1
  7310. C        I1=FV1(IBT).AND.LBITS(IBIT)
  7311. C        I2=FV2(IBT).AND.LBITS(IBIT)
  7312. C        I4=FV4(IBT).AND.LBITS(IBIT)
  7313.     KT1=ICHAR(FV1(IBT))
  7314.     KT2=ICHAR(FV2(IBT))
  7315.     KT4=ICHAR(FV4(IBT))
  7316.     KT8=ICHAR(LBITS(IBIT))
  7317. C    LT1=LT1.AND.LT8
  7318. C    LT2=LT2.AND.LT8
  7319. C    LT4=LT4.AND.LT8
  7320.     KT1=IMASK(KT1,KT8)
  7321.     KT2=IMASK(KT2,KT8)
  7322.     KT4=IMASK(KT4,KT8)
  7323. C    I1=CHAR(KT1)
  7324. C    I2=CHAR(KT2)
  7325. C    I4=CHAR(KT4)
  7326.         IVL=0
  7327.         IF(KT1.NE.0)IVL=1
  7328.         IF(KT2.NE.0)IVL=IVL+2
  7329.         IF(KT4.NE.0)IVL=-IVL
  7330.         IVAL=CHAR(IVL)
  7331. C READS OFF FVLD BYTE FROM 3 BITS, HIGH ONE IS SIGN. TREAT AS SIGN-
  7332. C MAGNITUDE NUMBER IN RANGE -3 TO +3,
  7333.         RETURN
  7334.         END
  7335. c -h- fvldst.for    Fri Aug 22 13:10:51 1986    
  7336.         SUBROUTINE FVLDST(ID1,ID2,IVAL)
  7337. C
  7338. C FVLDST - SET THE BYTE IN FVLD ARRAY
  7339. C NEXT BITMAPS IMPLEMENT FVLD
  7340.     Include Aparms.inc
  7341.         CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
  7342.     CHARACTER*1 FVXX(IMps3)
  7343.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  7344.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  7345.         Common/FVLDM/FVXX
  7346. c        COMMON/FVLDM/FV1,FV2,FV4
  7347.         CHARACTER*1 IVAL
  7348.         CHARACTER*1 LBITS(8)
  7349.     EXTERNAL INDX
  7350.         COMMON/BITS/LBITS
  7351. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  7352. C TYPES OF AC'S STORAGE:
  7353.         CHARACTER*1 ITYP(Imp1s)
  7354.         InTeGer*4 IATYP(27)
  7355.         COMMON/TYP/IATYP,ITYP
  7356.     InTeGer*4 ICREF,IRREF
  7357. C    COMMON/MIRROR/ICREF,IRREF
  7358.     InTeGer*4 MODPUB,LIMODE
  7359. C    COMMON/MODPUB/MODPUB,LIMODE
  7360.     InTeGer*4 KLKC,KLKR
  7361.     REAL*8 AACP,AACQ
  7362. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  7363.     InTeGer*4 NCEL,NXINI
  7364. C    COMMON/NCEL/NCEL,NXINI
  7365.     CHARACTER*1 NAMARY(20,MRows)
  7366. C    COMMON/NMNMNM/NAMARY
  7367.     InTeGer*4 NULAST,LFVD
  7368. C    COMMON/NULXXX/NULAST,LFVD
  7369.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  7370.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  7371. CCC    InTeGer*4 ICREF,IRREF
  7372. CCC    COMMON/MIRROR/ICREF,IRREF
  7373. C
  7374. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  7375. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  7376. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  7377. C AREAS WITH DATA.
  7378.     InTeGer*4 DLFG
  7379. C    COMMON/DLFG/DLFG
  7380.     InTeGer*4 KDRW,KDCL
  7381. C    COMMON/DOT/KDRW,KDCL
  7382.     InTeGer*4 DTRENA
  7383. C    COMMON/DTRCMN/DTRENA
  7384.     REAL*8 EP,PV,FV
  7385.     DIMENSION EP(20)
  7386.     INTEGER*4 KIRR
  7387. C    COMMON/ERNPER/EP,PV,FV,KIRR
  7388.     InTeGer*4 LASTOP
  7389. C    COMMON/ERROR/LASTOP
  7390.     CHARACTER*1 FMTDAT(9,76)
  7391. C    COMMON/FMTBFR/FMTDAT
  7392.     CHARACTER*1 EDNAM(16)
  7393. C    COMMON/EDNAM/EDNAM
  7394.     InTeGer*4 MFID(2),MFMOD(2)
  7395. C    COMMON/FRM/MFID,MFMOD
  7396.     InTeGer*4 JMVFG,JMVOLD
  7397. C    COMMON/FUBAR/JMVFG,JMVOLD
  7398.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  7399.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  7400. CCC        CHARACTER*1 FMTDAT(9,76)
  7401.     InTeGer*4 IVV,I1,I2,I3,ITA
  7402.     LOGICAL*4 L2,L1,LVV,LTA
  7403.     EQUIVALENCE(L2,I2),(L1,I1),(LVV,IVV)
  7404.     EQUIVALENCE(LTA,ITA)
  7405. CCC        COMMON/FMTBFR/FMTDAT
  7406.     CHARACTER*1 IT1,IT2,IT4,IT8
  7407.     LOGICAL*4 LT1,LT2,LT4,LT8
  7408.     InTeGer*4 KT1,KT2,KT4,KT8,KW1,KW2
  7409.     CHARACTER*1 IT12(2),IT22(2),IT42(2),IT82(2)
  7410.     EQUIVALENCE(LT1,IT12(1)),(LT2,IT22(1)),(LT4,IT42(1)),
  7411.      1  (LT8,IT82(1))
  7412.     EQUIVALENCE(KT1,IT12(1)),(KT2,IT22(1)),(KT4,IT42(1)),
  7413.      1  (KT8,IT82(1))
  7414. C INTEL 8088 USES 1ST CHAR IN HIGH BYTE SO FORCE IT1, IT2, IT4 ETC TO LOW
  7415. C ORDER BYTE WITH EQUIVALENCES
  7416. C    EQUIVALENCE(IT12(2),IT1),(IT22(2),IT2),(IT42(2),IT4),
  7417. C     1  (IT82(2),IT8)
  7418. C        CHARACTER*1 I4
  7419.     IF(ID2.EQ.1.AND.ID1.LE.MRC)GOTO 7806
  7420. C ALLOW DELIBERATE CALL WITH EFFECTIVELY ONE ARG.
  7421. 7807    CALL REFLEC(ID2,ID1,ID)
  7422.     GOTO 7808
  7423. 7806    CONTINUE
  7424. C        ID=(ID2-1)*60+ID1
  7425.     ID=ID1
  7426. 7808    IBT=((ID-1)/8)+1
  7427.     KT1=ID-1
  7428.     KT2=7
  7429.     KT1=IMASK(KT1,KT2)
  7430. C    LT1=LT1.AND.LT2
  7431.     IBIT=KT1+1
  7432. C        IBIT=((ID-1).AND.7)+1
  7433. C ZERO ALL 3 FVLD BITS FIRST
  7434. C        FV1(IBT)=FV1(IBT).AND..NOT.LBITS(IBIT)
  7435. C        FV2(IBT)=FV2(IBT).AND..NOT.LBITS(IBIT)
  7436. C        FV4(IBT)=FV4(IBT).AND..NOT.LBITS(IBIT)
  7437.     KT1=ICHAR(FV1(IBT))
  7438.     KT2=ICHAR(FV2(IBT))
  7439.     KT4=ICHAR(FV4(IBT))
  7440.     KT8=ICHAR(LBITS(IBIT))
  7441.     ITA=-KT8-1
  7442. C ITA IS NOW THE COMPLEMENT OF KT8
  7443. C THUS, THE SELECTED BIT IS OFF IN IT, ALL OTHERS ON.
  7444. C    LT1=LT1.AND.LTA
  7445. C    LT2=LT2.AND.LTA
  7446. C    LT4=LT4.AND.LTA
  7447.     KT1=IMASK(KT1,ITA)
  7448.     KT2=IMASK(KT2,ITA)
  7449.     KT4=IMASK(KT4,ITA)
  7450. C FILL IN ALL 3 BITMAPS WITH THEIR PREVIOUS CONTENTS EXCEPT THE
  7451. C CHOSEN BITS.
  7452.     FV1(IBT)=CHAR(KT1)
  7453.     FV2(IBT)=CHAR(KT2)
  7454.     FV4(IBT)=CHAR(KT4)
  7455.     IVVV=JCHAR(IVAL)
  7456.         IVV=IABS(IVVV)
  7457.         I3=0
  7458.         IF(IVVV.LT.0)I3=1
  7459. C    I1=1
  7460. C    I2=2
  7461.     KW2=2
  7462.     KW1=1
  7463.     I2=IMASK(IVV,KW2)
  7464.     I1=IMASK(IVV,KW1)
  7465. C        L2=LVV.AND.L2
  7466. C        L1=LVV.AND.L1
  7467. C NOTE WE ASSUME HEAVILY THAT LOGICAL OPERATIONS WORK BY BINARY
  7468. C ANDS AND ORS IN DATA.
  7469. C ** NOTE WE DON'T NEED TO RELOAD THE KT1 THRU KT4 INTEGERS... ALL ALREADY
  7470. C ARE LOADED... DITTO KT8
  7471. C    KT1=ICHAR(FV1(IBT))
  7472. C    KT2=ICHAR(FV2(IBT))
  7473. C    KT4=ICHAR(FV4(IBT))
  7474. C    KT8=ICHAR(LBITS(IBIT))
  7475.     LT1=LT1.OR.LT8
  7476.     LT2=LT2.OR.LT8
  7477.     LT4=LT4.OR.LT8
  7478. C        IF(I1.NE.0)FV1(IBT)=FV1(IBT).OR.LBITS(IBIT)
  7479. C        IF(I2.NE.0)FV2(IBT)=FV2(IBT).OR.LBITS(IBIT)
  7480. C        IF(I3.NE.0)FV4(IBT)=FV4(IBT).OR.LBITS(IBIT)
  7481.         IF(I1.NE.0)FV1(IBT)=CHAR(KT1)
  7482.         IF(I2.NE.0)FV2(IBT)=CHAR(KT2)
  7483.         IF(I3.NE.0)FV4(IBT)=CHAR(KT4)
  7484.         RETURN
  7485.         END
  7486. c -h- fvpeek.fms    Fri Aug 22 13:11:27 1986    
  7487. C DUMMY FVPEEK
  7488.     SUBROUTINE FVPEEK(ID1,ID2,IGO)
  7489.     InTeGer*4 ID1,ID2,IGO
  7490.     IGO=ID1
  7491.     RETURN
  7492.     END
  7493. c -h- getfnl.for    Fri Aug 22 13:12:09 1986    
  7494.     SUBROUTINE GETFNL(LINE,LSKP,LLEN)
  7495. C PARSE OUT FILENAME AND GET LSKP, LLEN NUMBERS
  7496.     EXTERNAL INDX
  7497.     CHARACTER*1 LINE(80)
  7498.     InTeGer*4 LSKP,LLEN,LO,HI
  7499.     LSKP=0
  7500.     LLEN=32000
  7501. C SET INITIAL NUMBERS TO READ WHOLE FILE
  7502.     KKK=ICHAR(',')
  7503.     N=INDX(LINE,KKK)
  7504.     IF(N.LE.0.OR.N.GT.78)RETURN
  7505. C IF CANNOT FIND COMMA, JUST SKIP OUT & TRY TO CATCH ERRORS ON OPEN.
  7506.     LINE(N)=0
  7507. C NULL TERMINATE FILENAME
  7508.     LO=N+1
  7509.     HI=LO+20
  7510.     CALL GN(LO,HI,LSKP,LINE)
  7511.     LO=N+1
  7512.     KKK=ICHAR(',')
  7513.     N=INDX(LINE(LO),KKK)
  7514.     IF(N.LE.0.OR.N.GT.30)RETURN
  7515.     LO=LO+N
  7516.     HI=LO+20
  7517.     CALL GN(LO,HI,LLEN,LINE)
  7518. C SHOULD HAVE NUMBERS NOW
  7519.     RETURN
  7520.     END
  7521. c -h- getlog.for    Fri Aug 22 13:12:16 1986    
  7522.     SUBROUTINE GETLOG(LINE,LMX,LOGTYP,LASST)
  7523.     CHARACTER*1 LINE(110)
  7524.     EXTERNAL INDX
  7525.     CHARACTER*1 LFN(4,6)
  7526.     CHARACTER*4 XLF(6)
  7527.     INTEGER*4 LF(6)
  7528.     EQUIVALENCE(XLF(1)(1:1),LF(1),LFN(1,1))
  7529. C    EQUIVALENCE(LF(1),LFN(1,1))
  7530.     DATA XLF/'.GT.','.LT.','.EQ.','.NE.','.GE.','.LE.'/
  7531. C LOGTYP RELATIONSHIP TO RELATIONSHIPS OF 2 VARIABLES
  7532. C IS DEFINED IN ABOVE DATA STMT.
  7533. C IF LINE CONTAINS STRING IN NAME, RETURN TYPE AND END LOC.
  7534.     LMX4=LMX-3
  7535.     DO 100 LL=1,6
  7536.     LOGTYP=LL
  7537.     DO 1 N1=1,LMX4
  7538.     IF(LINE(N1  ).NE.LFN(1,LL))GOTO 2
  7539.     IF(LINE(N1+1).NE.LFN(2,LL))GOTO 2
  7540.     IF(LINE(N1+2).NE.LFN(3,LL))GOTO 2
  7541.     IF(LINE(N1+3).NE.LFN(4,LL))GOTO 2
  7542. C HERE HAVE A MATCH
  7543.     LASST=N1
  7544. C RETURN LOC OF NEXT CHAR AFTER RELATION.
  7545.     GOTO 200
  7546. 2    CONTINUE
  7547. 1    CONTINUE
  7548. 100    CONTINUE
  7549.     LOGTYP=0
  7550. 200    CONTINUE
  7551.     RETURN
  7552.     END
  7553. c -h- getnnb.for    Fri Aug 22 13:13:44 1986    
  7554.     SUBROUTINE GETNNB(IPT,RETCD)
  7555. C COPYRIGHT (C) 1983 GLENN EVERHART
  7556. C ALL RIGHTS RESERVED
  7557. C 60=MAX REAL ROWS
  7558. C 301=MAX REAL COLS
  7559. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  7560. C VBLS AND TYPE DIMENSIONED 60,301
  7561. C **************************************************
  7562.  
  7563. C *                                                *
  7564. C *         SUBROUTINE GETNNB(IPT,RETCD)           *
  7565. C *                                                *
  7566. C **************************************************
  7567. C
  7568. C
  7569. C  GET NEXT NON-BLANK ELEMENT FROM LINE STARTING AT NONBLK+1
  7570. C
  7571. C  RETCD =  1   O.K.
  7572. C        2   NO NON-BLANK FOUND
  7573. C
  7574. C  IPT POINTS TO POSITION IN LINE WHERE NEXT NON-BLANK IS FOUND.
  7575. C  IT IS UP TO CALLING PROGRAM TO RESET NONBLK FOR NEXT SCAN.
  7576. C
  7577. C
  7578. C
  7579. C GETNNB IS CALLED BY
  7580. C
  7581. C AT
  7582. C BASCNG
  7583. C CMND
  7584. C NEXTEL
  7585. C STRCMP
  7586. C
  7587. C
  7588. C   VARIABLE    USE
  7589. C
  7590. C    BLANK      ' '
  7591. C    IPT        RETURNS POSITION OF NEXT NON-BLANK.
  7592. C    K          HOLDS TEMPORARY VALUES.
  7593. C    LEND       LAST NON-BLANK IN LINE(80).
  7594. C    NONBLK     HOLDS CHARACTER TO LEFT OF THE START OF THE SCAN.
  7595. C    RETCD      HOLDS THE RETURN CODE. 1=O.K.  2=THE REST IS BLANKS.
  7596. C
  7597. C
  7598. C    SUBROUTINE GETNNB(IPT,RETCD)
  7599. C
  7600. C
  7601.     InTeGer*4 IPT
  7602.     InTeGer*4 LEVEL,NONBLK,LEND
  7603.     InTeGer*4 VIEWSW,BASED,BASE,RETCD
  7604.     InTeGer*4 K
  7605. C
  7606.     CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  7607. C
  7608.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  7609.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  7610. C
  7611.     RETCD=1
  7612.     IF (NONBLK.GE.LEND) GOTO 999
  7613. C
  7614. C AT LEAST 1 NON-BLANK EXISTS.
  7615.     K=NONBLK+1
  7616.     DO 10 IPT=K,LEND
  7617.     IF (LINE(IPT).NE.BLANK) GOTO 1000
  7618. 10    CONTINUE
  7619. C
  7620. C
  7621. C ACTUALLY, SHOULD NEVER FALL THROUGH IF 'LEND' IS SET CORRECTLY.
  7622. C
  7623. C
  7624. C THE REST ARE BLANKS
  7625. 999    RETCD=2
  7626. 1000    RETURN
  7627.     END
  7628. c -h- getttl.for    Fri Aug 22 13:14:41 1986    
  7629.     SUBROUTINE GETTTL(LINE)
  7630.     Include AParms.inc
  7631.     CHARACTER*1 LINE(132)
  7632.     CHARACTER*3 FNAME
  7633.     CHARACTER*1 FN(3)
  7634.     EQUIVALENCE (FN(1),FNAME(1:1))
  7635.     InTeGer*4 IBBX
  7636.     InTeGer*4 ICREF,IRREF
  7637. C    COMMON/MIRROR/ICREF,IRREF
  7638.     InTeGer*4 MODPUB,LIMODE
  7639. C    COMMON/MODPUB/MODPUB,LIMODE
  7640.     InTeGer*4 KLKC,KLKR
  7641.     REAL*8 AACP,AACQ
  7642. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  7643.     InTeGer*4 NCEL,NXINI
  7644. C    COMMON/NCEL/NCEL,NXINI
  7645.     CHARACTER*1 NAMARY(20,MRows)
  7646. C    COMMON/NMNMNM/NAMARY
  7647.     InTeGer*4 NULAST,LFVD
  7648. C    COMMON/NULXXX/NULAST,LFVD
  7649.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  7650.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  7651. CCC    COMMON/MODPUB/MODPUB,LIMODE
  7652. C MODPUB = MODE USED IN CMD MODE GTMODE ROUTINE
  7653.     InTeGer*4 RRWACT,RCLACT
  7654. C    COMMON/RCLACT/RRWACT,RCLACT
  7655.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  7656.      1  IDOL7,IDOL8
  7657. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  7658. C     1  IDOL7,IDOL8
  7659.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  7660. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  7661.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  7662. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  7663. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  7664. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  7665.     InTeGer*4 KLVL
  7666. C    COMMON/KLVL/KLVL
  7667.     InTeGer*4 IOLVL,IGOLD
  7668. C    COMMON/IOLVL/IOLVL
  7669. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  7670. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  7671.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  7672.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  7673.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  7674.      3  k3dfg,kcdelt,krdelt,kpag
  7675. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  7676. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  7677. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  7678. CCC    InTeGer*4 LLCMD,LLDSP
  7679. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  7680. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  7681. C LIMODE IS WHAT GETS SET UP IN /# CMND
  7682.     IBBX=0
  7683. C
  7684. C
  7685. C
  7686. C
  7687. C CODE FOR FORTRAN READ...
  7688. C  **** HERE IS THE SECTION OF CODE YOU NEED FOR NON-VMS-SPECIFIC VERSION
  7689. C NOTE READS UNIT 0 TO GET CONSOLE.
  7690. C CHECK THAT WE'RE READING CONSOLE. IF LUN 5 IS OFF CONSOLE, THEN
  7691. C READ USING DIRECT DOS CALLS.
  7692. C  IF (STILL) IN AN INITIALIZER FILE, READ USING REGULAR FORTRAN READS
  7693. C AND ACT NORMALLY.
  7694. C  DISCOVER CONSOLE BECAUSE FILENAME IS 'CON:' OR 'CON'.
  7695. CC    INQUIRE(UNIT=5,NAME=FNAME)
  7696. CC    IF (FN(1).NE.'C'.OR.FN(2).NE.'O'.OR.FN(3).NE.'N')
  7697. CC     1 GOTO 5000
  7698. C CALL ASSEMBLER ROUTINE TO GET CHARACTERS.
  7699.     DO 5001 N=1,132
  7700. 5001    LINE(N)=CHAR(0)
  7701. C FIX IT UP SO A NULL LINE LOOKS HARMLESS...
  7702.     LINE(1)=' '
  7703. C NULL THE LINE FIRST IN FORTRAN; MAKES IT EASIER TO DO ASSEMBLER STUFF.
  7704.     CALL TTYIN(MODPUB,LINE)
  7705.     IF(LINE(1).NE.'/')GOTO 5540
  7706. C DISPLAY HELP MSG AT BOTTOM
  7707.     IF(MODPUB.EQ.0)GOTO 5540
  7708. C ONLY DISPLAY IF IN "AUTOENTER" MODE
  7709. c    CALL UVT100(1,LLDSP,1)
  7710. c    CALL SWRT('Add,Cpy,Dsp,Fil,Get,Kalc,Loc,Mov,Put,Recal,Set',46)
  7711. c    CALL SWRT(',Tst,View,Wrt,Xit,Zap,/,Help',28)
  7712. c    CALL UVT100(1,LLCMD,11)
  7713. C CALL TTYIN NEXT WITH 0 SO / ISN'T TERMINATOR.
  7714. c    N=0
  7715. C    CALL TTYIN(N,LINE(2))
  7716. 5540    CONTINUE
  7717.     IF(ICHAR(LINE(1)).EQ.26)
  7718.      1  GOTO 2000
  7719. C Add,Copy,Dsp,Fil,Get,Kalc,Loc,Mov,Put,Recal,Set,Test,View,Wrt,Xit,Zap,Help,/
  7720. C READ IN AFTER CLOSE AND RE-OPEN IF WE GET EOF ON INPUT SIGNALLED
  7721. C BY CONTROL Z.
  7722. C ASSUME WE'LL USE DOS FUNCTION 1 FOR READIN AND ECHO
  7723. C AND THEN END THE READIN AFTER FIRST CONTROL SEQUENCE.
  7724. C    GOTO 6000
  7725. C5000    CONTINUE
  7726. C    READ(5,1000,END=2000,ERR=2000)LINE
  7727. 1000    FORMAT(132A1)
  7728. 6000    CONTINUE
  7729. CC    IF(ICHAR(LINE(1)).NE.0)RETURN
  7730. CCC IF WE GET 0 MAYBE IT'S AN EXTENDED CODE. TRY RETURNING A HASHED
  7731. CCC VALUE HERE. USE __{CELL WHERE CELL IS A FOLLOWED BY (B+CODE) WHERE
  7732. CC CODE IS THE VALUE RETURNED...
  7733. CC    LINE(5)=CHAR(ICHAR(LINE(2))+66-59)
  7734. CC EXTENDED CODES WE CARE ABOUT START AT 59.
  7735. CC MAP INTO EXTENDED AC'S STARTING AT AB SINCE AA IS THE SAME AS % ACCUMULATOR
  7736. CC WHICH CAN'T BE REASSIGNED THIS WAY.
  7737. C    LINE(5)=CHAR(ICHAR(LINE(2))+7)
  7738. C    LINE(1)='_'
  7739. C    LINE(2)='_'
  7740. C    LINE(3)='{'
  7741. C    LINE(4)='A'
  7742. C
  7743. C WE SHOULD "KNOW" COORDS HERE DESIRED...
  7744. C THEY RUN FROM B TO Z...IMPLYING ID1=28 THRU 53
  7745. CC    II=ICHAR(LINE(5))-66+28
  7746. C    II=ICHAR(LINE(5))-38
  7747. C SCREEN OUT EXTRA JUNK THAT WOULD COME FROM HIGH FUNCT CODES...
  7748. C (DON'T BOTHER MAPPING A<Z+1> TO BA AND SO ON... ONLY 6
  7749. C KEYS IN USABLE RANGE ANYHOW...
  7750. C    IF(II.GT.52)GOTO 1200
  7751. C    III=1
  7752. C    CALL FVLDGT(II,III,IBBX)
  7753. C    IF(IBBX.EQ.0)GOTO 1200
  7754. C SKIP OVER CELLS THAT ARE EMPTY.
  7755. C
  7756. C NULL OUT REMAINDER OF THE LINE TO AVOID CONFUSION HERE.
  7757. C NOTE WE ONLY DO THIS WHERE WE SAW AN INITIAL NULL INDICATING AN
  7758. C EXTENDED FUNCTION INPUT.
  7759. C    IBBX=6
  7760. C    GOTO 1201
  7761. C1200    IBBX=1
  7762. C1201    CONTINUE
  7763. C    DO 1100 N=IBBX,132
  7764. C1100    LINE(N)=CHAR(0)
  7765.     RETURN
  7766. 2000    CONTINUE
  7767. c    CLOSE(18)
  7768.     IOLVL=11
  7769. c    OPEN(18,FILE='CON:20/40/150/150/Analy Command Input')
  7770.     CLOSE(3)
  7771. CC RETRY A READ AFTER EOF...
  7772. Cc try a write to 5 to see if that'll reset the file
  7773. c    Rewind 11
  7774. c    write(11,4002)
  7775. 4002    format(' *eof*')
  7776. c    Rewind 11
  7777.     Call vget(line,80)
  7778. c    READ(11,1000,END=4000,ERR=4000)LINE
  7779. c    rewind 11
  7780.     RETURN
  7781. 4000    CONTINUE
  7782. CC IF WE KEEP GETTING ERRORS, JUST QUIT.
  7783. CC AT LEAST STAY AROUND. USER CAN DO @\DEV\CON
  7784. CC TO PARTLY RECOVER...
  7785. C    STOP
  7786. C TRY TO RESET TTY EOF
  7787. C *********
  7788.     RETURN
  7789.     END
  7790. c -h- gmadd.for    Fri Aug 22 13:16:31 1986    
  7791.     SUBROUTINE GMADD(IA1,IA2,IB1,IB2,IR1,IR2,N,M)
  7792. C MODIFIED FOR PCCPC
  7793.     Include AParms.Inc
  7794. C      SUBROUTINE GMADD(A,B,R,N,M)
  7795.        REAL*8 A,B,R
  7796.        DIMENSION A(1),B(1),R(1)
  7797. C      NM=N*M
  7798.     IAB=(IA2-1)*MCols+IA1-1
  7799.     IBB=(IB2-1)*MCols+IB1-1
  7800.     IRB=(IR2-1)*MCols+IR1-1
  7801.       DO 10 I=1,N
  7802.       DO 10 J=1,M
  7803.     IJ=(I-1)*MCols+J
  7804.     CALL XVBLGT(IJ+IAB,0,A)
  7805.     CALL XVBLGT(IJ+IBB,0,B)
  7806.     R(1)=A(1)+B(1)
  7807.     CALL XVBLST(IJ+IRB,0,R)
  7808. 10    CONTINUE
  7809. C   10 R(IJ)=A(IJ)+B(IJ)
  7810.       RETURN
  7811.       END
  7812. c -h- gmprd.for    Fri Aug 22 13:16:31 1986    
  7813.     SUBROUTINE GMPRD(IA1,IA2,IB1,IB2,IR1,IR2,N,M,L)
  7814.     Include AParms.Inc
  7815. C      SUBROUTINE GMPRD(A,B,R,N,M,L)
  7816.     REAL*8 A,B,R
  7817.         DIMENSION A(1),B(1),R(1)
  7818. C SPECIAL MATRIX MULTIPLY WITHIN SPREADSHEET MATRIX
  7819.     IAB=(IA2-1)*MCols+IA1-1
  7820.     IBB=(IB2-1)*MCols+IB1-1
  7821.     IRB=(IR2-1)*MCols+IR1-1
  7822.     DO 10 K=1,L
  7823.     DO 10 J=1,M
  7824.     NL=(J-1)*MCols+K
  7825.     R(1)=0.
  7826.     CALL XVBLST(IRB+NL,0,R)
  7827.     DO 10 I=1,N
  7828.     NM=(J-1)*MCols+I
  7829.     ML=(I-1)*MCols+K
  7830.     CALL XVBLGT(IAB+NM,0,A)
  7831.     CALL XVBLGT(IBB+ML,0,B)
  7832.     A(1)=A(1)*B(1)
  7833.     CALL XVBLGT(IRB+NL,0,R)
  7834.     R(1)=R(1)+A(1)
  7835. 10    CALL XVBLST(IRB+NL,0,R)
  7836. C    R(NL)=R(NL)+A(NM)*B(ML)
  7837. C10    CONTINUE
  7838.       RETURN
  7839.       END
  7840. c -h- gmsub.for    Fri Aug 22 13:16:31 1986    
  7841.     SUBROUTINE GMSUB(IA1,IA2,IB1,IB2,IR1,IR2,N,M)
  7842. C      SUBROUTINE GMSUB(A,B,R,N,M)
  7843.     Include AParms.Inc
  7844.     REAL*8 A,B,R
  7845.     IAB=(IA2-1)*MCols+IA1-1
  7846.     IBB=(IB2-1)*MCols+IB1-1
  7847.     IRB=(IR2-1)*MCols+IR1-1
  7848. C      NM=N*M
  7849.       DO 10 I=1,N
  7850.       DO 10 J=1,M
  7851.       IJ=(I-1)*MCols+J
  7852.     CALL XVBLGT(IAB+IJ,0,A)
  7853.     CALL XVBLGT(IBB+IJ,0,B)
  7854.     A=A-B
  7855.     CALL XVBLST(IRB+IJ,0,A)
  7856. 10    CONTINUE
  7857. C   10 R(IJ)=A(IJ)-B(IJ)
  7858.       RETURN
  7859.       END
  7860. c -h- gmtx.for    Fri Aug 22 13:16:31 1986    
  7861.     SUBROUTINE GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
  7862.      1  ID2B,RETCD)
  7863.  
  7864.     CHARACTER*1 LINE(80)
  7865. C REQ END MTX NAME IN 20 CHARS.
  7866. C SHOULD BE OK
  7867.     LEND=IBGN+20
  7868. C GET LOC OF MATRIX A (MUST BE SQUARE)
  7869.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  7870.     IF(IVALID.EQ.0)GOTO 300
  7871.     IF(LINE(LSTCHR).NE.':')GOTO 300
  7872.     IBGN=LSTCHR+1
  7873.     LEND=IBGN+20
  7874.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  7875.     IF(IVALID.EQ.0)GOTO 300
  7876. 1000    RETURN
  7877. 300    RETCD=3
  7878.     RETURN
  7879.     END
  7880. c -h- gn.for    Fri Aug 22 13:16:49 1986    
  7881.     SUBROUTINE GN(LAST,LEND,NUM,LINE)
  7882.     IMPLICIT InTeGer*4(A-Z)
  7883. C    PARAMETER 1=1,14=14
  7884.     DIMENSION LINE(110)
  7885.     CHARACTER*1 LINE
  7886.     EXTERNAL INDX
  7887.     CHARACTER*1 NCH
  7888.     InTeGer*4 CH,SFG
  7889.     NUM=0
  7890.     JSSF=0
  7891.     ISSF=0
  7892.     CH=0
  7893.     SFG=1
  7894.     NCH=0
  7895.     DO 1 N=LAST,LEND
  7896.     M=N
  7897.     NCH=LINE(N)
  7898.     CH=ICHAR(NCH)
  7899.     IF(CH.EQ.0)GOTO 2
  7900.     IF(CH.EQ.45)SFG=-1
  7901. C SFG=SIGN FLAG
  7902. C 43 IS ASCII FOR +; 45 IS ASCII FOR - SIGN.
  7903. C IGNORE + SIGNS
  7904.     IF(CH.GT.32)ISSF=ISSF+1
  7905.     IF(ISSF.EQ.0.AND.CH.EQ.32)GOTO 1
  7906. C IGNORE SPACES TOO, PROVIDED THEY ARE LEADING SPACES.
  7907. C (OTHERS MAY BE DELIMITERS.)
  7908.     IF(CH.EQ.43.OR.CH.EQ.45)JSSF=JSSF+1
  7909.     IF(JSSF.GT.1.AND.(CH.EQ.43.OR.CH.EQ.45))GOTO 2
  7910. C IF WE HAVEN'T SEEN A +/- PROCESS IT HERE.
  7911.     IF(CH.EQ.43)GOTO 1
  7912.     IF(CH.EQ.45)GOTO 1
  7913.     IF(CH.LT.48.OR.CH.GT.57)GOTO 2
  7914. C TERMINATE ON ANY NON NUMERIC. SHOULD ALLOW TERMINATE ON SECOND #.
  7915.     IF(NUM.LT.3100)NUM=10*NUM+(CH-48)
  7916. 1    CONTINUE
  7917. C NEXT LINE WAS MAX0...
  7918. 2    LAST=MIN0(M,LEND)
  7919.     NUM=NUM*SFG
  7920. C ACCOUNTED FOR SIGN; NOW RETURN
  7921.     RETURN
  7922.     END
  7923. c -h- gtmung.for    Fri Aug 22 13:17:12 1986    
  7924.     SUBROUTINE GTMUNG(LINE)
  7925.     Include AParms.inc
  7926.     CHARACTER*1 LINE(132)
  7927.     InTeGer*4 IMODE
  7928.     CHARACTER*1 C2
  7929.     InTeGer*4 ICREF,IRREF
  7930. C    COMMON/MIRROR/ICREF,IRREF
  7931.     InTeGer*4 MODPUB,LIMODE
  7932. C    COMMON/MODPUB/MODPUB,LIMODE
  7933.     InTeGer*4 KLKC,KLKR
  7934.     REAL*8 AACP,AACQ
  7935. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  7936.     InTeGer*4 NCEL,NXINI
  7937. C    COMMON/NCEL/NCEL,NXINI
  7938.     CHARACTER*1 NAMARY(20,MRows)
  7939. C    COMMON/NMNMNM/NAMARY
  7940.     InTeGer*4 NULAST,LFVD
  7941. C    COMMON/NULXXX/NULAST,LFVD
  7942.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  7943.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  7944. CCC    COMMON/MODPUB/MODPUB,LIMODE
  7945.     DATA IMODE/0/
  7946. C HANDLE EXTRA MODE PARSING...DEFAULT,TO AVOID ENTER CMD IF NOT NEEDED.
  7947.     I=ICHAR(LINE(1))
  7948.     IF(I.LT.34.OR.I.GT.122)GOTO 6000
  7949.     IF(I.EQ.42)GOTO 6000
  7950. C ASSUME OTHER REASONABLE CHARS ARE CMDS
  7951.     IF(I.GT.34.AND.I.LT.40)GOTO 6000
  7952.     IF(I.EQ.95)GOTO 6000
  7953.     IF(I.GE.58.AND.I.LE.64)GOTO 6000
  7954.     IF(LINE(1).NE.'/')GOTO 100
  7955.     IF(LINE(2).NE.'/')GOTO 110
  7956. C SETUP OLD MODE WITH //
  7957.     IMODE=0
  7958.     GOTO 900
  7959. 110    CONTINUE
  7960.     IF(LINE(2).NE.';')GOTO 120
  7961. C SETUP NEW MODE WITH /;
  7962.     IMODE=1
  7963.     GOTO 900
  7964. 120    CONTINUE
  7965.     IF(LINE(2).NE.'#')GOTO 124
  7966. C SWAP OLD, CURRENT MODES
  7967. C USE IN CMD FILES SO /# SWAPS MODES, THEN // SETS OLD MODE,
  7968. C THEN /# SWAPS BACK
  7969. C (THAT WAY, USER'S MODE DOESN'T CHANGE.)
  7970.     I=LIMODE
  7971.     LIMODE=IMODE
  7972.     IMODE=I
  7973.     GOTO 900
  7974. 124    CONTINUE
  7975.     IF(IMODE.EQ.0)GOTO 6000
  7976. C IF WE JUST SAW /COMMAND, MUNGE OUT THE INITIAL /
  7977.     DO 130 I=1,131
  7978. 130    LINE(I)=LINE(I+1)
  7979.     GOTO 6000
  7980. 100    CONTINUE
  7981.     IF(IMODE.EQ.0)GOTO 6000
  7982. C INPUT DIDN'T START WITH / SO TRY AND MAKE UP AN ENTER
  7983.     IF(LINE(2).EQ.'&')GOTO 6000
  7984. C 1& 2& ETC WORK STILL AS CURSOR CONTROLS
  7985.     C2='N'
  7986.     IF(LINE(1).EQ.'"')C2='"'
  7987. C    IF(LINE(1).GE.'0'.AND.LINE(1).LE.'9')C2='V'
  7988.     IF(LINE(1).LT.'0'.OR.LINE(1).GT.'9')GOTO 170
  7989. C INITIAL CHAR IS A DIGIT. IF 2ND CHAR IS ALSO A DIGIT OR
  7990. C SOMETHING REASONABLE THEN TREAT AS "EV" CMD. OTHERWISE
  7991. C JUST PASS AS A COMMAND SO CURSOR CTLS WORK STILL.
  7992.     IF(LINE(2).LE.' ')GOTO 6000
  7993. C ALLOW DIGIT FOLLOWED BY SPACE OR C.R. TO BE JUST CURSOR MOVE
  7994.     C2='V'
  7995. 170    CONTINUE
  7996. C MOVE DOWN PAST 'EV'
  7997.     II=3
  7998. C ALLOW US TO REMOVE INITIAL " IN E" CASE...
  7999.     IF(C2.EQ.'"')II=2
  8000.     DO 150 I=1,129
  8001.     M=133-I
  8002.     MM=M-II
  8003. 150    LINE(M)=LINE(MM)
  8004.     LINE(1)='E'
  8005.     LINE(2)=C2
  8006.     LINE(3)=' '
  8007.     GOTO 6000
  8008. 900    LINE(1)='*'
  8009. C MAKE COMMENT, THEN GO
  8010. 6000    CONTINUE
  8011. C MAINTAIN MODE FOR REST OF WORLD
  8012.     MODPUB=IMODE
  8013.     RETURN
  8014.     END
  8015. c -h- gtprd.for    Fri Aug 22 13:17:12 1986    
  8016.     SUBROUTINE GTPRD(IA1,IA2,IB1,IB2,IR1,IR2,N,M,L)
  8017.     Include Aparms.inc
  8018.     REAL*8 A,B,R
  8019.       DIMENSION A(1),B(1),R(1)
  8020. C SPECIAL MATRIX MULTIPLY WITHIN SPREADSHEET MATRIX
  8021.     IAB=(IA2-1)*MCols+IA1-1
  8022.     IBB=(IB2-1)*MCols+IB1-1
  8023.     IRB=(IR2-1)*MCols+IR1-1
  8024.     DO 10 K=1,L
  8025.     DO 10 J=1,M
  8026.     NL=(J-1)*MCols+K
  8027.     R(1)=0.
  8028.     CALL XVBLST(NL+IRB,0,R)
  8029.     DO 10 I=1,N
  8030. C INVERT ROW/COLUMN USE FOR MATRIX A
  8031.     NM=(I-1)*MCols+J
  8032.     ML=(I-1)*MCols+K
  8033.     CALL XVBLGT(IAB+NM,0,A)
  8034.     CALL XVBLGT(IBB+ML,0,B)
  8035.     A(1)=A(1)*B(1)
  8036.     CALL XVBLGT(IRB+NL,0,R)
  8037.     R(1)=R(1)+A(1)
  8038.     CALL XVBLST(IRB+NL,0,R)
  8039. C    R(NL)=R(NL)+A(NM)*B(ML)
  8040. 10    CONTINUE
  8041.       RETURN
  8042.       END
  8043. c -h- index.fdd    Fri Aug 22 13:20:45 1986    
  8044.       INTEGER FUNCTION INDX ( STR, C )
  8045. C
  8046.     INTEGER*4 C
  8047.       CHARACTER * 1 STR ( 1 )
  8048. C
  8049. C LIMIT RANGE OF SEARCH TO 256 BYTES. THIS IS ARBITRARY BUT I DOUBT
  8050. C ANALYTICALC WILL EVER DEAL IN LONGER STRINGS THAN THIS AND
  8051. C SEARCHES ALL OVER THE CREATION ARE TO BE AVOIDED.
  8052.     I3B=0
  8053.       DO 20019  I = 1, 256
  8054.       IF (ICHAR(STR(I)).NE.0) GOTO 20021
  8055. C RETURN INDEX AS EITHER THE LOCATION OF THE CHARACTER OR 0
  8056.       INDX=0
  8057.       RETURN
  8058. 20021 CONTINUE
  8059.     IF(ICHAR(STR(I)).EQ.255)I3B=3
  8060.     IF(I3B.LE.0)GOTO 2000
  8061. C SKIP ENCODED VARIABLES
  8062.     I3B=I3B-1
  8063.     GOTO 20019
  8064. 2000    CONTINUE
  8065.       IF (.NOT.( STR ( I ) .EQ. CHAR(C) )) GOTO 20023
  8066.     ix=i
  8067.     if(i.gt.250)ix=0
  8068.       INDX = ( IX )
  8069.       RETURN
  8070. 20023 CONTINUE
  8071. 20022 CONTINUE
  8072. C
  8073. 20019 CONTINUE
  8074. 20020 CONTINUE
  8075.     INDX=255
  8076.     RETURN
  8077.       END
  8078. c -h- in2as.for    Fri Aug 22 13:21:02 1986    
  8079.     SUBROUTINE IN2AS(ROW,CHRS)
  8080.     InTeGer*4 ROW
  8081.     CHARACTER*1 CHRS(4)
  8082.     INTEGER*4 AC,AC1,AC2
  8083.     DO 1 N1=1,4
  8084. 1    CHRS(N1)=CHAR(32)
  8085. C CONVERT ROW TO LETTERS. ASSUMES COL=2 OR MORE. ROW 1=A-Z
  8086. C ROW 2=AA-AZ, THEN BA-BZ ETC.
  8087.     AC=ROW
  8088.     DO 2 N=1,4
  8089.     M=5-N
  8090. C CONVERT BACKWARDS INTO CHRS
  8091.     AC1=(AC/26)
  8092.     AC2=AC1*26
  8093.     IX=AC-AC2
  8094.     IF(.NOT.(IX.EQ.0.AND.AC1.GT.0))GOTO 772
  8095. C CORRECT SO WE GET Z, NOT A<NULL> FOR LABELS.
  8096.     IX=26
  8097.     AC1=AC1-1
  8098. 772    CONTINUE
  8099.     IF(IX.GT.0)CHRS(M)=CHAR(IX+64)
  8100. C CONVERT TO ASCII A-Z CHARACTER
  8101.     AC=AC1
  8102. 2    CONTINUE
  8103. C JUST IGNORE ANY OVERFLOW.
  8104.     RETURN
  8105.     END
  8106. c -h- indxq.for    Fri Aug 22 13:21:14 1986    
  8107.       INTEGER FUNCTION INDXQ ( STR, C )
  8108. C
  8109.     INTEGER*4 C
  8110.       CHARACTER * 1 STR ( 1 )
  8111. C
  8112. C LIMIT RANGE OF SEARCH TO 256 BYTES. THIS IS ARBITRARY BUT I DOUBT
  8113. C ANALYTICALC WILL EVER DEAL IN LONGER STRINGS THAN THIS AND
  8114. C SEARCHES ALL OVER THE CREATION ARE TO BE AVOIDED.
  8115.     I3B=0
  8116.       DO 20019  I = 1, 256
  8117.       IF (ICHAR(STR(I)).NE.0) GOTO 20021
  8118. C RETURN INDEX AS EITHER THE LOCATION OF THE CHARACTER OR OF THE
  8119. C END OF THE STRING FOR ANALYTICALC. NOTE THAT THIS DIFFERS
  8120. C FROM USUAL RATFOR VERSION.
  8121.       INDXQ=I
  8122.       RETURN
  8123. 20021 CONTINUE
  8124.     IF(ICHAR(STR(I)).EQ.255)I3B=3
  8125.     IF(I3B.LE.0)GOTO 2000
  8126. C SKIP ENCODED VARIABLES
  8127.     I3B=I3B-1
  8128.     GOTO 20019
  8129. 2000    CONTINUE
  8130.       IF (.NOT.( STR ( I ) .EQ. CHAR(C) )) GOTO 20023
  8131.       INDXQ = ( I )
  8132.       RETURN
  8133. 20023 CONTINUE
  8134. 20022 CONTINUE
  8135. C
  8136. 20019 CONTINUE
  8137. 20020 CONTINUE
  8138.     INDXQ=0
  8139.     RETURN
  8140.       END
  8141. c -h- inpost.for    Fri Aug 22 13:21:23 1986    
  8142.     SUBROUTINE INPOST (RETCD)
  8143. C COPYRIGHT (C) 1983 GLENN EVERHART
  8144. C ALL RIGHTS RESERVED
  8145. C 60=MAX REAL ROWS
  8146. C 301=MAX REAL COLS
  8147. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  8148. C VBLS AND TYPE DIMENSIONED 60,301
  8149. C **************************************************
  8150. C *                                                *
  8151. C *            SUBROUTINE  INPOST                  *
  8152. C *                                                *
  8153. C **************************************************
  8154. C
  8155. C
  8156. C  CONVERTS THE INPUT STRING (INFIX NOTATION) TO POSTFIX
  8157. C  FOR LATER EVALUATION BY POSTVL
  8158. C
  8159. C
  8160. C
  8161. C  MODIFICATION CODES:  M3,M10
  8162. C
  8163. C
  8164. C MODIFIED 10-MAR-78 P.B. CHANGED STACK VALUE FOR FUNCTIONS FROM 15 TO 45
  8165. C   THIS CORRECTS IMPROPER EVALUATION OF SQRT(1.)-2.
  8166. C
  8167. C
  8168. C
  8169. C
  8170. C INPOST CALLS
  8171. C
  8172. C  ERRMSG   PRINTS ERROR MESSAGES
  8173. C  NEXTEL   GETS THE NEXT ELEMENT FROM LINE(80)
  8174. C
  8175. C
  8176. C
  8177. C INPOST IS CALLED BY CALC
  8178. C
  8179. C
  8180. C
  8181. C
  8182. C
  8183. C
  8184. C        THE VARIABLE AND FUNCTION CODES.
  8185. C TABLE ALSO GIVES COMPARE VALUES AND STACK VALUES OF
  8186. C FUNCTIONS THAT OCCUR WHEN EXPRESSIONS ARE EVALUATED.
  8187. C
  8188. C
  8189. C
  8190. C
  8191. C    STACK
  8192. C    ELEMENT                COMPARE    STACK
  8193. C    CODE    TYPE        BYTES    VALUE    VALUE
  8194. C
  8195. C    0    UNDEFINED    -    -    -
  8196. C    1    ASCII        1    -    -
  8197. C    2    DECIMAL        8    -    -
  8198. C    3    HEXADECIMAL    4    -    -
  8199. C    4    INTEGER        4    -    -
  8200. C    5    MULT.PREC.(10)    20    -    -
  8201. C    6    MULT.PREC.(8)    20    -    -
  8202. C    7    MULT.PREC.(16)    20    -    -
  8203. C    8    OCTAL        4    -
  8204. C    9    REAL        8    -    -
  8205. C    10-30    UNDEFINED    -    -    -
  8206. C
  8207. C    ----------FUNCTIONS------------
  8208. C
  8209. C    31    ABS (=DABS)    -    70    45
  8210. C    32    IABS        -    70    45
  8211. C    33    FLOAT        -    70    45
  8212. C    34    IFIX        -    70    45
  8213. C    35    AINT        -    70    45
  8214. C    36    INT (=IDINT)    -    70    45
  8215. C    37    EXP (=DEXP)    -    70    45
  8216. C    38    ALOG (=DLOG)    -    70    45
  8217. C    39    ALOG10(=DLOG10)    -    70    45
  8218. C    40    SQRT (=DSQRT)    -    70    45
  8219. C    41    SIN (=DSIN)    -    70    45
  8220. C    42    COS (=DCOS)    -    70    45
  8221. C    43    TANH (=DTANH)    -    70    45
  8222. C    44    ATAN (=DATAN)    -    70    45
  8223. C    45-47    ASIN,ACOS,TAN    -    70    45
  8224. C    45    RESERVED    -    -    -
  8225. C       48-100  RESERVED        -       -       -
  8226. C
  8227. C       110     (               -       70      15
  8228. C       111     UNARY -         -       50      49
  8229. C       112     **              -       40      39
  8230. C       113     *               -       30      31
  8231. C       114     /               -       30      31
  8232. C       115     +               -       20      21
  8233. C       116     -               -       20      21
  8234. C       117     )               -       10      -
  8235. C
  8236. C       200     =               -       10      10
  8237. C
  8238. C
  8239. C
  8240. C    VARIABLE      USE
  8241. C
  8242. C    I,K          HOLDS TEMPORARY InTeGer*4 VALUES.
  8243. C    LASTOP       HOLDS THE TYPE OF LAST ELEMENT OBTAINED
  8244. C                 ON LINE(80). SET AT 0 AT BEGINNING OF EXPRESSION.
  8245. C                 USED BY NEXTEL TO IDENTIFY UNARY OPERATORS.
  8246. C    NONBLK       POINTER IN LINE(80). NEXTEL STARTS SCAN AT NONBLK+1.
  8247. C    OPVAL(200,2)   HOLDS THE COMPARE AND STACK VALUE OF EACH OPERATOR.
  8248. C    PARVAL       HOLDS 110 WHICH IS THE CODE FOR '(' IN STACK 2.
  8249. C    RETCD        RETURN CODE. 1=O.K.  2=ERROR.
  8250. C    RETCD2       RETURN CODE FOR CALL TO NEXTEL.
  8251. C    RETTYP       HOLDS TYPE OF NEXT ELEMENT IN LINE, EITHER A FUNCTION
  8252. C                 CODE OR A DATA TYPE CODE.
  8253. C    RETVAL(100)  HOLDS VALUE OF NEXT ELEMENT IN LINE(80).
  8254. C    ST1LIM       HOLDS LIMIT OF STACK 1.
  8255. C    ST2LIM       HOLDS LIMIT OF STACK 2.
  8256. C    ST1PT        STACK 1 POINTER.
  8257. C    ST2PT        STACK 2 POINTER.
  8258. C    ST1TYP       TYPE OF EACH ELEMENT IN STACK 1
  8259. C    ST2TYP       TYPE OF EACH ELEMENT IN STACK 2
  8260. C    VLEN         HOLDS THE NUMBER OF BYTES USED BY EACH DATA TYPE.
  8261. C
  8262. C
  8263. C
  8264. C
  8265. C    SUBROUTINE INPOST (RETCD)
  8266. C
  8267. C
  8268. C
  8269.     InTeGer*4 LEVEL,NONBLK,LEND
  8270.     InTeGer*4 LASTOP
  8271.     InTeGer*4 VIEWSW,BASED
  8272.     InTeGer*4 OPVAL(200,2),PARVAL
  8273.     InTeGer*4 RETCD,RETCD2,RETTYP
  8274.     InTeGer*4 TYPE(1,1)
  8275.     InTeGer*4 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT
  8276.     InTeGer*4 ST1LIM,ST2LIM
  8277.     InTeGer*4 VLEN(9)
  8278.     InTeGer*4 I,K
  8279. C
  8280.     CHARACTER*1 LINE(80)
  8281.     CHARACTER*1 AVBLS(20,27),RETVAL(20)
  8282.     CHARACTER*1 VBLS(8,1,1)
  8283.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  8284. C
  8285. C
  8286.     COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  8287.      1  ST1LIM,ST2LIM
  8288.     COMMON /V/TYPE,AVBLS,VBLS,VLEN
  8289.     InTeGer*4 DLFG
  8290. C    COMMON/DLFG/DLFG
  8291.     InTeGer*4 KDRW,KDCL
  8292. C    COMMON/DOT/KDRW,KDCL
  8293.     InTeGer*4 DTRENA
  8294. C    COMMON/DTRCMN/DTRENA
  8295.     REAL*8 EP,PV,FV
  8296.     DIMENSION EP(20)
  8297.     INTEGER*4 KIRR
  8298. C    COMMON/ERNPER/EP,PV,FV,KIRR
  8299. c    InTeGer*4 LASTOP
  8300. C    COMMON/ERROR/LASTOP
  8301.     CHARACTER*1 FMTDAT(9,76)
  8302. C    COMMON/FMTBFR/FMTDAT
  8303.     CHARACTER*1 EDNAM(16)
  8304. C    COMMON/EDNAM/EDNAM
  8305.     InTeGer*4 MFID(2),MFMOD(2)
  8306. C    COMMON/FRM/MFID,MFMOD
  8307.     InTeGer*4 JMVFG,JMVOLD
  8308. C    COMMON/FUBAR/JMVFG,JMVOLD
  8309.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  8310.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  8311. CCC    COMMON /ERROR/ LASTOP
  8312.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  8313. C
  8314. C
  8315.     DATA OPVAL/30*-1,17*70,62*-1,70,50,40,30,30,20,20,10,82*-1,10,
  8316.      1             30*-1,17*45,62*-1,15,49,39,31,31,21,21,-1,82*-1,10/
  8317.     DATA PARVAL/110/
  8318. C
  8319. C
  8320. C
  8321. C
  8322. C
  8323. C  INITIALIZE STACKS, RETURN CODE DEFAULT, AND LASTOP
  8324.     RETCD=1
  8325.     ST1PT=1
  8326.     ST2PT=1
  8327.     LASTOP=0
  8328. C
  8329. C SET UP FOR NEXTEL CALL
  8330.     NONBLK=NONBLK-1
  8331. C
  8332. C
  8333. C
  8334. C
  8335. C **************************************************
  8336. C ***** GET NEXT ELEMENT OF EXPRESSION *************
  8337. C **************************************************
  8338. C
  8339. C
  8340. C
  8341. C  NEXTEL RETURNS
  8342. C    1    IF OPERAND
  8343. C    2    IF OPERATOR (VALUE IN RETTYP)
  8344. C    3    IF NO MORE ELEMENTS
  8345. C    4    IF ERROR
  8346. C
  8347. C
  8348. 50    CALL NEXTEL (RETVAL,RETTYP,RETCD2)
  8349.     GOTO (100,200,300,999),RETCD2
  8350.     STOP 50
  8351. C
  8352. C
  8353. C
  8354. C
  8355. C
  8356. C **************************************************
  8357. C ********  OPERAND FOUND, PUT ON STACK 1  *********
  8358. C **************************************************
  8359. C
  8360. C STACK 1 OVERFLOW CHECK
  8361. 100    IF (ST1PT.GT.ST1LIM) GOTO 990
  8362. C
  8363. C
  8364. C
  8365. C
  8366. C
  8367. 109    CONTINUE
  8368. C
  8369. C  SUBROUTINE ERRCX HAS ALREADY ASSURED THAT
  8370. C  IF AN OPERAND IS FOLLOWED BY AN = SIGN, THAT VARIABLE
  8371. C  IS NOT PART OF AN EXPRESSION.
  8372. C
  8373. C  VARIABLE INDEX IS TO BE PLACED IN STACK1 (1,ST1PT)
  8374. C  SO IF YOU WANTED TO SPEED THE OPERATION AT THE EXPENSE
  8375. C  OF SPACE, YOU WOULD ONLY COPY RETVAL(1) IF RETTYP < 0
  8376.     K=VLEN(IABS(RETTYP))
  8377.     DO 110 I=1,K
  8378. 110    STACK1(I,ST1PT)=RETVAL(I)
  8379.     ST1TYP(ST1PT)=RETTYP
  8380.     ST1PT=ST1PT+1
  8381.     GOTO 50
  8382. C
  8383. C
  8384. C
  8385. C
  8386. C
  8387. C
  8388. C
  8389. C
  8390. C **************************************************
  8391. C *****************  OPERATOR  *********************
  8392. C **************************************************
  8393. C
  8394. 200    CONTINUE
  8395. C
  8396. C IF NO OTHER OPERATOR ON STACK 2, PLACE ON STACK 2
  8397.     IF (ST2PT.EQ.1) GOTO 222
  8398. C
  8399. C
  8400. C COMPARE VALUE WITH OPERATOR IN STACK2, IF GREATER OR EQUAL THEN
  8401. C PLACE IN STACK 2 BECAUSE IT HAS HIGHER PRECEDENCE AND IS ASSOCIATED
  8402. C WITH PREVIOUSLY ENCOUNTERED OPERAND, IS A UNARY OPERATOR ASSOCIATED
  8403. C WITH THE FOLLOWING ELEMENT, OR IS A '(' WHICH IS SAVED UNTIL A ')'
  8404. C IS FOUND.
  8405. C
  8406.     K=ST2TYP(ST2PT-1)
  8407.     IF (OPVAL(RETTYP,1).GE.OPVAL(K,2)) GOTO 220
  8408. C
  8409. C
  8410. C IF POPPING OFF ELEMENTS FROM STACK2 BECAUSE ')' WAS FOUND THEN WHEN
  8411. C ')' IS FOUND WE GO TO 230 TO REMOVE THE OPERATOR '(' FROM STACK 2.
  8412. C
  8413.     IF (PARVAL.EQ.K) GOTO 230
  8414.     IF (ST1PT.GT.ST1LIM) GOTO 990
  8415. C
  8416. C
  8417. C
  8418. C OPERATOR ON STACK 2 GOES ONTO STACK 1.
  8419. C
  8420.     ST1TYP(ST1PT)=K
  8421.     ST1PT=ST1PT+1
  8422.     ST2PT=ST2PT-1
  8423.     GOTO 200
  8424. C
  8425. C
  8426. C  PUT OPERATOR ON STACK 2
  8427. 220    IF (ST2PT.GT.ST2LIM) GOTO 992
  8428. 222    ST2TYP(ST2PT)=RETTYP
  8429.     ST2PT=ST2PT+1
  8430.     GOTO 50
  8431. C
  8432. C
  8433. C REMOVE '(' FROM STACK 2
  8434. 230    ST2PT=ST2PT-1
  8435.     GOTO 50
  8436. C
  8437. C
  8438. C
  8439. C
  8440. C
  8441. C **************************************************
  8442. C ******* NO MORE ELEMENTS IN LINE *****************
  8443. C **************************************************
  8444. C
  8445. C CLEAN OFF STACK 2
  8446. 300    IF (ST2PT.EQ.1) GOTO 1000
  8447. C
  8448. C IF A '(' GO TO 350 TO THROW IT AWAY.
  8449.     IF (ST2TYP(ST2PT-1).EQ.PARVAL) GOTO 350
  8450.     IF (ST1PT.GT.ST1LIM) GOTO 990
  8451. C
  8452. C
  8453. C
  8454. C PLACE ELEMENT ON STACK 2 ONTO STACK 1.
  8455. C
  8456.     ST1TYP(ST1PT)=ST2TYP(ST2PT-1)
  8457.     ST1PT=ST1PT+1
  8458. C
  8459. C THROW AWAY '(' FROM STACK 2.
  8460. 350    ST2PT=ST2PT-1
  8461.     GOTO 300
  8462. C
  8463. C
  8464. C
  8465. C
  8466. C *** ERROR HANDLING ***
  8467. C
  8468. C STACK 1 OVERFLOW
  8469. 990    I=7
  8470.     GO TO 998
  8471. C
  8472. C STACK 2 OVERFLOW
  8473. 992    I=9
  8474. C
  8475. C
  8476. 998    CALL ERRMSG(I)
  8477. 999    RETCD=2
  8478. 1000    RETURN
  8479. C
  8480.     END
  8481. c -h- isgn.for    Fri Aug 22 13:21:52 1986    
  8482.       INTEGER FUNCTION ISGN(IARG)
  8483.       InTeGer*4 IARG
  8484.       IF(IARG.EQ.0)ISGN=0
  8485.       IF(IARG.GT.0)ISGN=1
  8486.       IF(IARG.LT.0)ISGN=-1
  8487.       RETURN
  8488.       END
  8489. c -h- jchar.for    Fri Aug 22 13:22:15 1986    
  8490.     INTEGER FUNCTION JCHAR(CHR)
  8491.     CHARACTER*1 CHR
  8492. c    INTEGER*1 ICH
  8493. C RETURN INTEGER VALUE OF CHARACTER AS IF IT WERE A SIGNED
  8494. C INTEGER BETWEEN -128 AND +127
  8495.     INTEGER*4 I
  8496. c    EQUIVALENCE(CHR,ICH)
  8497.     I=ICHAR(CHR)
  8498. c    I=ICH
  8499.     IF(I.GT.127)I=I-256
  8500.     JCHAR=I
  8501.     RETURN
  8502.     END
  8503. c -h- jmod.for    Fri Aug 22 13:22:15 1986    
  8504. C INTEGER*4 MODULO FUNCTION
  8505.     INTEGER*4 FUNCTION JMOD(I1,I2)
  8506.     INTEGER*4 I1,I2,I
  8507.     I=MOD(I1,I2)
  8508.     JMOD=I
  8509.     RETURN
  8510.     END
  8511. c -h- julasc.for    Fri Aug 22 13:22:15 1986    
  8512.     SUBROUTINE JULASC(N,DATST,IYR,IMO,IDA)
  8513. C CONVERT JULIAN DATE N INTO ASCII STRING STR
  8514.     INTEGER*4 DATST(2),DAT(2)
  8515.     CHARACTER*1 DATSTR(8)
  8516.     CHARACTER*2 YRST(1),MOST(1),DAST(1)
  8517.     EQUIVALENCE(YRST(1)(1:1),DATSTR(1)),
  8518.      1  (MOST(1)(1:1),DATSTR(4))
  8519.     EQUIVALENCE(DAT(1),DATSTR(1))
  8520.     EQUIVALENCE(DAST(1)(1:1),DATSTR(7))
  8521.     InTeGer*4 MLEN(12)
  8522.     DATA MLEN/31,28,31,30,31,30,31,31,30,31,30,31/
  8523.     DATSTR(3)='/'
  8524.     DATSTR(6)='/'
  8525. C FIRST SUBTRACT OFF WHOLE YEARS
  8526.     IYR=N/365
  8527.     N=N-(365*IYR)
  8528. C ADJUST FOR LEAP YRS SINCE 1981
  8529.     IAC=IYR/4
  8530.     N=N-IAC
  8531. C Account for when this year is a leap year
  8532.     MLEN(2)=28
  8533.     IF(Mod((IYR+81),4).eq.0) MLEN(2)=29
  8534. c (OK for rest of 20th century, anyhow.)
  8535. C (Also OK in 21st, since 2000 IS a leap year (divisible by 400))
  8536. C NOW SUBTRACT OFF MONTHS AS LONG AS POSSIBLE
  8537.     DO 1 NN=1,12
  8538.     IMO=NN
  8539.     IF(N.LE.MLEN(NN))GOTO 2
  8540.     N=N-MLEN(NN)
  8541. 1    CONTINUE
  8542. 2    CONTINUE
  8543.     IDA=N
  8544.     IYR=IYR+81
  8545.     WRITE(YRST(1)(1:2),3,ERR=5)IYR
  8546. C    ENCODE(2,3,YRST,ERR=5)IYR
  8547. 3    FORMAT(I2)
  8548.     WRITE(MOST(1)(1:2),3,ERR=5)IMO
  8549. C    ENCODE(2,3,MOST,ERR=5)IMO
  8550.     WRITE(DAST(1)(1:2),3,ERR=5)IDA
  8551. C    ENCODE(2,3,DAST,ERR=5)IDA
  8552. 5    CONTINUE
  8553.     IF(DATSTR(1).EQ.' ')DATSTR(1)='0'
  8554.     IF(DATSTR(4).EQ.' ')DATSTR(4)='0'
  8555.     IF(DATSTR(7).EQ.' ')DATSTR(7)='0'
  8556.     DATST(1)=DAT(1)
  8557.     DATST(2)=DAT(2)
  8558. C USE INTEGERS SINCE REAL*8 MIGHT OMIT FULL COPY IF
  8559. C EXPONENT BYTE IS 0, AND CHARS MAY CAUSE NORMALIZATION
  8560. C PROBLEMS SOMETIMES.
  8561.     RETURN
  8562.     END
  8563. c -h- julian.for    Fri Aug 22 13:22:15 1986    
  8564. C JULIAN DATE ROUTINES
  8565. C CALLS:
  8566. C    N=JULIAN(YY/MM/DD)
  8567. C    RETURNS JULIAN DATE BASED ON 1/1/80 FOR THAT DATE
  8568. C
  8569. C    CALL JULASC(N,STRADR)
  8570. C    TAKES JULIAN DATE AND DECODES TO ASCII YY/MM/DD
  8571. C
  8572. C    N=JULMDY(IYR,IMO,IDA)
  8573. C    RETURNS JULIAN DATE GIVEN SEPARATE Y,M,D
  8574. C
  8575.     FUNCTION JULIAN(DATST)
  8576.     INTEGER*4 DATST(2),DAT(2)
  8577.     CHARACTER*1 DATSTR(8)
  8578.  
  8579.     CHARACTER*1 YRST(2),MOST(2),DAST(2)
  8580.     CHARACTER*2 YRST2,MOST2,DAST2
  8581.     EQUIVALENCE(YRST2(1:1),YRST(1),DATSTR(1),DAT(1)),
  8582.      1  (MOST2(1:1),MOST(1),DATSTR(4)),
  8583.      2  (DAST2(1:1),DAST(1),DATSTR(7))
  8584. C    EQUIVALENCE(DATSTR(1),DAT(1))
  8585. C    EQUIVALENCE(YRST(1),DATSTR(1)),(MOST(1),DATSTR(4))
  8586. C    EQUIVALENCE(DAST(1),DATSTR(7))
  8587.     DAT(1)=DATST(1)
  8588.     DAT(2)=DATST(2)
  8589.     IJUL=1
  8590.     READ(YRST2(1:2),1,ERR=2)IYR
  8591. C    DECODE(2,1,YRST,ERR=2)IYR
  8592. 1    FORMAT(I2)
  8593.     READ(MOST2(1:2),1,ERR=2)IMO
  8594.     READ(DAST2(1:2),1,ERR=2)IDA
  8595. C    DECODE(2,1,MOST,ERR=2)IMO
  8596. C    DECODE(2,1,DAST,ERR=2)IDA
  8597.     IJUL=JULMDY(IYR,IMO,IDA)
  8598. 2    CONTINUE
  8599.     JULIAN=IJUL
  8600.     RETURN
  8601.     END
  8602. c -h- julmdy.for    Fri Aug 22 13:22:15 1986    
  8603.     FUNCTION JULMDY(IYR,IMO,IDA)
  8604.     InTeGer*4 MLEN(12)
  8605.     DATA MLEN/31,28,31,30,31,30,31,31,30,31,30,31/
  8606. C JULIAN DATE FROM Y,M,D
  8607. C BASE=1/1/81
  8608.     IJUL=1
  8609.     IF(IYR.LT.80)GOTO 999
  8610.     IYR=IYR-81
  8611.     IF(IMO.LE.0.OR.IMO.GT.12)GOTO 999
  8612.     IF(IDA.GT.31)GOTO 999
  8613. C JUST RETURN ILLEGAL ENTRIES AS 1/1/80
  8614.     AC=365.25*FLOAT(IYR)
  8615.     IAC=AC
  8616. C SLIGHTLY CRUDE BUT WORKABLE TREATMENT OF YEARS
  8617.     IJUL=IJUL+IAC
  8618. C NOW ADD IN MONTHS.
  8619.     IF(IMO.GT.2.AND.MOD(IYR+1,4).EQ.0)IJUL=IJUL+1
  8620. C ABOVE ACCOUNTS FOR LEAP YEARS
  8621.     III=IMO-1
  8622.     IF(III.LE.0)GOTO 22
  8623.     DO 2 N=1,III
  8624. 2    IJUL=IJUL+MLEN(N)
  8625. 22    CONTINUE
  8626. C NEXT DO DAYS
  8627.     IJUL=IJUL+IDA-1
  8628. C JUST ADD IN DAYS. SHOULD BE GOOD ENOUGH.
  8629. 999    CONTINUE
  8630.     JULMDY=IJUL
  8631.     RETURN
  8632.     END
  8633. c -h- jvblgt.for    Fri Aug 22 13:22:15 1986    
  8634.         SUBROUTINE JVBLGT(ID1,ID2,ID3,IVAL)
  8635. C
  8636. C JVBLGT - GET INTEGER*4 WORD OF 3 DIM VBLS ARRAY, ORIGINALLY
  8637. C  DIMENSIONED (2,60,301). HANDLE BY CALLING XVBLGT TO GET
  8638. C  CORRECT 8 BYTE VARIABLE, AND PULLING OUT CORRECT ONE
  8639.         InTeGer*4 ID1,ID2,ID3
  8640.         INTEGER*4 IVAL,LL(2)
  8641.         REAL*8 XX
  8642.         EQUIVALENCE(LL(1),XX)
  8643.         CALL XVBLGT(ID2,ID3,XX)
  8644.         IVAL=LL(ID1)
  8645.         RETURN
  8646.         END
  8647. c -h- jvblst.for    Fri Aug 22 13:22:15 1986    
  8648.         SUBROUTINE JVBLST(ID1,ID2,ID3,IVAL)
  8649. C JVBLST - SET I*4 WORD OF 3 DIM VBLS ARRAY, ORIGINALLY
  8650. C  DIMENSIONED (2,60,301). HANDLE BY CALLING XVBLST TO GET
  8651. C  CORRECT 8 BYTE VARIABLE, AND PUTTING IN CORRECT ONE
  8652.         InTeGer*4 ID1,ID2,ID3
  8653.         INTEGER*4 IVAL,LL(2)
  8654.         REAL*8 XX
  8655.         EQUIVALENCE(LL(1),XX)
  8656. C GET THE DESIRED 8 BYTES, THEN CHANGE THE ONES WE WANT. THEN...
  8657.         CALL XVBLGT(ID2,ID3,XX)
  8658.         LL(ID1)=IVAL
  8659. C PUT BACK THE 8 BYTES.
  8660.         CALL XVBLST(ID2,ID3,XX)
  8661.         RETURN
  8662.         END
  8663. c -h- mdet.for    Fri Aug 22 13:25:39 1986    
  8664.     SUBROUTINE MDET(XVBLS,I1,I2,J1,J2,DET)
  8665.     Include Aparms.inc
  8666.     REAL*8 XVBLS(1),DET,SUMA,SUMB
  8667. C NOTE XVBLS IS 60 BY 301 MATRIX IN PORTACALC
  8668. C I1,I2 ARE TOP COL,ROW COORD; J1,J2 ARE BOTTOM
  8669. C STORAGE OF XVBLS IS (COL,ROW) SO LOCATIONS INSIDE
  8670. C IT ARE
  8671. C  ADDR=(ROW-1)*60+COL (60 IS # OF COLS)
  8672.     DET=0.
  8673.     N=J1-I1+1
  8674.     M=J2-I2+1
  8675.     IF(N.NE.M)RETURN
  8676.     IF(N.LE.1)RETURN
  8677. C ONLY SQUARE MATRICES MAY HAVE NONZERO DETERMINANTS
  8678. C ALSO, DIMENSION HAS TO BE > 1
  8679.     NN=N
  8680. C  FIXUP... (OK FOR N=2,3 ANYHOW)
  8681.     IF(N.EQ.2)NN=N-1
  8682. C  SUM OVER DIAGS...
  8683. C MULTIPLY DIAGONALS FROM TOP AND BOTTOM ROWS OF MATRIX AND GET
  8684. C DIFFERENCE EACH TIME FOR ACCURACY
  8685.     DO 1 N1=1,NN
  8686.     SUMA=1.
  8687.     SUMB=1.
  8688.     DO 2 N2=1,N
  8689.     NCL=N1+N2-1
  8690.     N2L=N+1-N2
  8691.     IF(NCL.GT.N)NCL=NCL-N
  8692. C NOW MULTIPLY SUMA (POSITIVE TERMS) BY X(NCL,N2) AND SUMB(NEG TERMS)
  8693. C BY X(NCL,N2L)
  8694.     LA=(N2-2+I2)*MCols+I1+NCL-1
  8695.     LB=(N2L-2+I2)*MCols+I1+NCL-1
  8696.     CALL XVBLGT(LA,0,XVBLS(1))
  8697.     SUMA=SUMA*XVBLS(1)
  8698.     CALL XVBLGT(LB,0,XVBLS(1))
  8699.     SUMB=SUMB*XVBLS(1)
  8700. 2    CONTINUE
  8701. C NOW ACCUMULATE TERMS IN DETERMINANT
  8702.     DET=DET+SUMA-SUMB
  8703. C DO IN THIS ORDER TO AVOID EXCESSIVE LOSS OF PRECISION DUE TO
  8704. C DIFFERENCES OF LARGE TERMS. THIS IS BAD ENOUGH AS IT IS...
  8705. 1    CONTINUE
  8706.     RETURN
  8707.     END
  8708. c -h- mthini.for    Fri Aug 22 13:25:45 1986    
  8709.     SUBROUTINE MTHINI(INDEXF,AC,SS,CTR,ACX)
  8710.     DIMENSION EP(20)
  8711.     InTeGer*4 DLFG
  8712. C    COMMON/DLFG/DLFG
  8713.     InTeGer*4 KDRW,KDCL
  8714. C    COMMON/DOT/KDRW,KDCL
  8715.     InTeGer*4 DTRENA
  8716. C    COMMON/DTRCMN/DTRENA
  8717.     REAL*8 EP,PV,FV
  8718.     DIMENSION EP(20)
  8719.     INTEGER*4 KIRR
  8720. C    COMMON/ERNPER/EP,PV,FV,KIRR
  8721.     InTeGer*4 LASTOP
  8722. C    COMMON/ERROR/LASTOP
  8723.     CHARACTER*1 FMTDAT(9,76)
  8724. C    COMMON/FMTBFR/FMTDAT
  8725.     CHARACTER*1 EDNAM(16)
  8726. C    COMMON/EDNAM/EDNAM
  8727.     InTeGer*4 MFID(2),MFMOD(2)
  8728. C    COMMON/FRM/MFID,MFMOD
  8729.     InTeGer*4 JMVFG,JMVOLD
  8730. C    COMMON/FUBAR/JMVFG,JMVOLD
  8731.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  8732.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  8733. CCC    REAL*8 EP,PV,FV
  8734. CCC    COMMON/ERNPER/EP,PV,FV,KIRR
  8735.     REAL*8 AC,SS,CTR,ACX
  8736.     KIRR=0
  8737.     SS=0.
  8738.     CTR=0.
  8739.     ACX=0.
  8740.     DO 1 N=1,20
  8741. 1    EP(N)=0.
  8742.     AC=0.
  8743.     IF(INDEXF.EQ.1)AC=1.E20
  8744.     IF(INDEXF.EQ.2)AC=-1.E20
  8745.     RETURN
  8746.     END
  8747. c -h- mtxequ.for    Fri Aug 22 13:25:54 1986    
  8748.        SUBROUTINE MTXEQU(A1,A2,B1,B2,N,M,D)
  8749.     Include AParms.inc
  8750. C A1,A2 ARE DIMENSIONS OF A SUBMATRIX ORIGIN IN XVBLS
  8751. C B1,B2 ARE DIMS OF B SUBMATRIX
  8752. C
  8753. C NOTE THIS PROGRAM MUST BE MODIFIED TO WORK WITHIN THE SPREAD
  8754. C SHEET MATRIX RATHER THAN JUST ASSUMING THAT THE N DIMENSION
  8755. C AND M DIMENSION GIVE THE STORAGE ADDRESSES... ALTERNATIVELY,
  8756. C THE PROGRAM MUST OPERATE ONLY ON COPIED, DENSELY STORED
  8757. C MATRICES.
  8758. C
  8759. C
  8760. C   ORIGINAL PROGRAM TEXT FOLLOWS:
  8761. C       DIMENSION A(1),B(1)
  8762. CC ALTER DECLARATIONS FOR USE WITH SPREAD SHEET
  8763. C    REAL*8 A,B
  8764. C       KMAX=N-1
  8765. C       DO 90 K=1,KMAX
  8766. C       AMAX=0.
  8767. C       J2=K
  8768. C       DO 20 J1=K,N
  8769. C       IK=(J1-1)*N+K
  8770. C       IF(ABS(AMAX)-ABS(A(IK)))10,20,20
  8771. C10       AMAX=A(IK)
  8772. C       J2=J1
  8773. C20       CONTINUE
  8774. CC       EXCHANGE ROW K,J2 IF NECESSARY
  8775. C       IF(J2-K)30,60,30
  8776. C30       DO 40 J=K,N
  8777. C       J3=(K-1)*N+J
  8778. C       J4=(J2-1)*N+J
  8779. C       SAVE=A(J3)
  8780. C       A(J3)=A(J4)
  8781. C       A(J4)=SAVE
  8782. C40       CONTINUE
  8783. C       DO 50 J=1,M
  8784. C       J3=(K-1)*M+J
  8785. C       J4=(J2-1)*M+J
  8786. C       SAVE=B(J3)
  8787. C       B(J3)=B(J4)
  8788. C50       B(J4)=SAVE
  8789. CC       REDUCTION
  8790. C60       K1=K+1
  8791. C       KK=(K-1)*N+K
  8792. C       DO 80 I=K1,N
  8793. C       IK=(I-1)*N+K
  8794. C       DO 70 J=K1,N
  8795. C       IJ=(I-1)*M+J
  8796. C       KJ=(K-1)*M+J
  8797.  
  8798. C70       A(IJ)=A(IJ)-A(KJ)*A(IK)/A(KK)
  8799. C       DO 80 J=1,M
  8800. C       IJ=(I-1)*M+J
  8801. C       KJ=(K-1)*N+J
  8802. C80       B(IJ)=B(IJ)-B(KJ)*A(IK)/A(KK)
  8803. C90       CONTINUE
  8804. CC       SUBSTITUTE BACK
  8805. CC       NN=(N-1)*N+N
  8806. C       NN=N*N
  8807. C       DO 110 J=1,M
  8808. C       NJ=(N-1)*M+J
  8809. C       B(NJ)=B(NJ)/A(NN)
  8810. C       I1MAX=N-1
  8811. C       IF(I1MAX)110,110,95
  8812. C95       DO 111 I1=1,I1MAX
  8813. C       I=N-I1
  8814. C       IJ=(I-1)*M+J
  8815. C       II=(I-1)*N+I
  8816. C       I2=I+1
  8817. C       DO 100 L=I2,N
  8818. C       IL=(I-1)*N+L
  8819. C       LJ=(L-1)*M+J
  8820. C100       B(IJ)=B(IJ)-A(IL)*B(LJ)
  8821. C       B(IJ)=B(IJ)/A(II)
  8822. C111       CONTINUE
  8823. C110       CONTINUE
  8824. C       RETURN
  8825. C       END
  8826.     INTEGER A1,A2,B1,B2
  8827. C       DIMENSION A(1),B(1)
  8828. C ALTER DECLARATIONS FOR USE WITH SPREAD SHEET
  8829. C NOTE THAT OUR COLUMN DIMENSION IS 60, NOT N OR M HERE
  8830. C SUBSCRIPTS ARE (ROW-1)*COL-DIMENSION + COL
  8831. C  THEREFORE, CHANGE *N OR *M IN SUBSCRIPT COMPUTATIONS TO
  8832. C  *60
  8833.     REAL*8 A,B,AW1,AW2,BW1,BW2,AW3,AW4,AMAX
  8834.     INTEGER ABASE,BBASE
  8835.     ABASE=(A2-1)*MCols+A1-1
  8836.     BBASE=(B2-1)*MCols+B1-1
  8837.     D=1.
  8838.        KMAX=N-1
  8839.        DO 90 K=1,KMAX
  8840.        AMAX=0.
  8841.        J2=K
  8842.        DO 20 J1=K,N
  8843.        IK=(J1-1)*MCols+K
  8844.     CALL XVBLGT(IK+ABASE,0,A)
  8845.        IF(DABS(AMAX)-DABS(A))10,20,20
  8846. 10       AMAX=A
  8847.        J2=J1
  8848. 20       CONTINUE
  8849. C       EXCHANGE ROW K,J2 IF NECESSARY
  8850.        IF(J2-K)30,60,30
  8851. 30       DO 40 J=K,N
  8852.        J3=(K-1)*MCols+J
  8853.        J4=(J2-1)*MCols+J
  8854.     CALL XVBLGT(J3+ABASE,0,SAVE)
  8855. C       SAVE=A(J3)
  8856.     CALL XVBLGT(J4+ABASE,0,AW1)
  8857.     CALL XVBLST(J3+ABASE,0,AW1)
  8858.     CALL XVBLST(J4+ABASE,0,SAVE)
  8859. C       A(J3)=A(J4)
  8860. C       A(J4)=SAVE
  8861. 40       CONTINUE
  8862.        DO 50 J=1,M
  8863.        J3=(K-1)*MCols+J
  8864.        J4=(J2-1)*MCols+J
  8865. C       SAVE=B(J3)
  8866. C       B(J3)=B(J4)
  8867. C50       B(J4)=SAVE
  8868.     CALL XVBLGT(J3+BBASE,0,SAVE)
  8869.     CALL XVBLGT(J4+BBASE,0,BW1)
  8870.     CALL XVBLST(J3+BBASE,0,BW1)
  8871.     CALL XVBLST(J4+BBASE,0,SAVE)
  8872. 50    CONTINUE
  8873. C       REDUCTION
  8874. 60       K1=K+1
  8875.        KK=(K-1)*MCols+K
  8876.     CALL XVBLGT(KK+ABASE,0,A)
  8877.     IF(A.EQ.0)GOTO 999
  8878. C    IF(A(KK).EQ.0.)GOTO 999
  8879.        DO 80 I=K1,N
  8880.        IK=(I-1)*MCols+K
  8881.        DO 70 J=K1,N
  8882.        IJ=(I-1)*MCols+J
  8883.        KJ=(K-1)*MCols+J
  8884. C70       A(IJ)=A(IJ)-A(KJ)*A(IK)/A(KK)
  8885.     CALL XVBLGT(IJ+ABASE,0,AW1)
  8886.     CALL XVBLGT(KJ+ABASE,0,AW2)
  8887.     CALL XVBLGT(IK+ABASE,0,AW3)
  8888.     CALL XVBLGT(KK+ABASE,0,AW4)
  8889.     AW1=AW1-AW2*AW3/AW4
  8890.     CALL XVBLST(IJ+ABASE,0,AW1)
  8891. 70    CONTINUE
  8892.        DO 80 J=1,M
  8893.        IJ=(I-1)*MCols+J
  8894.        KJ=(K-1)*MCols+J
  8895. C80       B(IJ)=B(IJ)-B(KJ)*A(IK)/A(KK)
  8896.     CALL XVBLGT(IJ+BBASE,0,BW1)
  8897.     CALL XVBLGT(KJ+BBASE,0,BW2)
  8898.     BW1=BW1-BW2*AW3/AW4
  8899.     CALL XVBLST(IJ+BBASE,0,BW1)
  8900. 80    CONTINUE
  8901. 90       CONTINUE
  8902. C       SUBSTITUTE BACK
  8903.        NN=(N-1)*MCols+N
  8904. C       NN=N*N
  8905.     CALL XVBLGT(NN+ABASE,0,AW1)
  8906.     IF(AW1.EQ.0.)GOTO 999
  8907.        DO 110 J=1,M
  8908.        NJ=(N-1)*MCols+J
  8909. C       B(NJ)=B(NJ)/A(NN)
  8910.     CALL XVBLGT(NJ+BBASE,0,BW1)
  8911.     BW1=BW1/AW1
  8912.     CALL XVBLST(NJ+BBASE,0,BW1)
  8913.        I1MAX=N-1
  8914.        IF(I1MAX)110,110,95
  8915. 95       DO 111 I1=1,I1MAX
  8916.        I=N-I1
  8917.        IJ=(I-1)*MCols+J
  8918.        II=(I-1)*MCols+I
  8919.        I2=I+1
  8920.     CALL XVBLGT(II+ABASE,0,AW1)
  8921.        DO 100 L=I2,N
  8922.        IL=(I-1)*MCols+L
  8923.        LJ=(L-1)*MCols+J
  8924. C100       B(IJ)=B(IJ)-A(IL)*B(LJ)
  8925.     CALL XVBLGT(IJ+BBASE,0,BW1)
  8926.     CALL XVBLGT(IL+ABASE,0,AW2)
  8927.     CALL XVBLGT(LJ+BBASE,0,BW2)
  8928.     BW1=BW1-AW2*BW2
  8929.     CALL XVBLST(IJ+BBASE,0,BW1)
  8930. 100    CONTINUE
  8931. C       B(IJ)=B(IJ)/A(II)
  8932.     BW1=BW1/AW1
  8933.     CALL XVBLST(IJ+BBASE,0,BW1)
  8934. 111       CONTINUE
  8935. 110       CONTINUE
  8936.        RETURN
  8937. 999    CONTINUE
  8938.     D=0.
  8939.     RETURN
  8940.        END
  8941. C *********************  AnalyF6.Ftn ###################################
  8942. c -h- varscn.for    Fri Aug 22 13:37:17 1986    
  8943. C $DO66
  8944.     SUBROUTINE VARSCN(LINE,IBGN,LEND,LSTCHR,ID1,ID2,IVALID)
  8945. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  8946. C ALL RIGHTS RESERVED
  8947. C
  8948. C VARSCN - SCAN COMMAND LINE FOR VARIABLE NAMES.
  8949. C
  8950. C    SCANS FOR VARIABLE NAMES OF FORM AAANNN WHERE AAA = LETTERS
  8951. C BETWEEN A AND Z UP TO NON-ALPHA, CORRESPONDING TO ROW, FOLLOWED BY
  8952. C NUMBERS IN THE 0-9 RANGE MAKING A DECIMAL COLUMN NUMBER.
  8953. C
  8954. C THE LETTERS ARE FORMED BY
  8955. C A-Z ALONE GIVE ROW 1-26, COL 1. % IS ROW 27,COL1
  8956. C A1-Z1 GIVE ROW 1-26, COL 2
  8957. C AA1-ZZ1 ARE ROW 27-52, COL 2
  8958. C
  8959. C In this version we also recognize cell names using an optional third
  8960. C dimension. Forms like B14#2 would be interpreted as cell B14 of sheet
  8961. C 2 (sheets start at 0). This is a display trick mainly, as cell offsets
  8962. C will be treated as simple 2D addresses as before. However, it will allow
  8963. C some greater automation of the notion of multiple areas. Each "page" is
  8964. C formed by adding constants KCDELT and KRDELT to the column and row
  8965. C of the base number, multiplied by the offset in sheets. These constants
  8966. C are initially zero, collapsing all "pages" on top of one another. This
  8967. C interpretation will occur provided K3DFG is 0 or positive. If it is 
  8968. C negative all 3D interpretation will be ignored, and even parsing of
  8969. C the cell names for trailing # characters will be disabled. (This will
  8970. C allow strict return to the older meanings.)
  8971.     IMPLICIT InTeGer*4 (A-Z)
  8972. C NOTE COL 1 IS DUMMY. DISPLAY THE SHEET SIDEWAYS SO WE GET USUAL VISUAL
  8973. C ROWS, COLS., AND ACCUMULATORS A-Z,% JUST APPEAR AS A FICTITIOUS ROW 0
  8974. C ON DISPLAY, INSTEAD OF REAL COLUMN 1 HERE.
  8975.     Include AParms.Inc
  8976.     DIMENSION LINE(LEND)
  8977.     CHARACTER*1 LINE
  8978.     InTeGer*4 TYPE(1,1),VLEN(9)
  8979.     REAL*8 XVBLS(1,1)
  8980.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  8981.     REAL*8 XAVB,xac
  8982.     REAL*4 XAV2(2)
  8983.     CHARACTER*1 XAV1(8)
  8984.     EXTERNAL INDX
  8985.     EQUIVALENCE(XAVB,XAV2(1)),(XAVB,XAV1(1))
  8986.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  8987.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  8988. C ***<<< KLSTO COMMON START >>>***
  8989.     InTeGer*4 DLFG
  8990. C    COMMON/DLFG/DLFG
  8991.     InTeGer*4 KDRW,KDCL
  8992. C    COMMON/DOT/KDRW,KDCL
  8993.     InTeGer*4 DTRENA
  8994. C    COMMON/DTRCMN/DTRENA
  8995.     REAL*8 EP,PV,FV
  8996.     DIMENSION EP(20)
  8997.     INTEGER*4 KIRR
  8998. C    COMMON/ERNPER/EP,PV,FV,KIRR
  8999.     InTeGer*4 LASTOP
  9000. C    COMMON/ERROR/LASTOP
  9001.     CHARACTER*1 FMTDAT(9,76)
  9002. C    COMMON/FMTBFR/FMTDAT
  9003.     CHARACTER*1 EDNAM(16)
  9004. C    COMMON/EDNAM/EDNAM
  9005.     InTeGer*4 MFID(2),MFMOD(2)
  9006. C    COMMON/FRM/MFID,MFMOD
  9007.     InTeGer*4 JMVFG,JMVOLD
  9008. C    COMMON/FUBAR/JMVFG,JMVOLD
  9009.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  9010.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  9011. C ***<<< KLSTO COMMON END >>>***
  9012. CCC    InTeGer*4 DLFG
  9013. CCC    COMMON/DLFG/DLFG
  9014. C DLFG=1 IF D## FORMS ARE SEEN
  9015.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  9016.     COMMON/D2R/NRDSP,NCDSP
  9017. C NRDSP AND NCDSP ARE REAL ROW, COL OF DISPLAY ROW, COL CELLS. NOTE THAT
  9018. C NOT ALL DISPLAY CELLS ARE ALWAYS ACTUALLY SHOWN; ONLY THOSE THAT FIT
  9019. C ARE SHOWN; THE REST "EXIST" BUT DON'T APPEAR UNLESS ROWS ARE SMALL
  9020. C ENOUGH.
  9021. C
  9022. C THIS PROGRAM ALSO HANDLES CELL SPECS OF FORM
  9023. C P#+nnn#+nnn (or P#-nnn#-mmm) FOR Physical cells relative to our current
  9024. C physical cell on the sheet (clamped at boundaries), or of form
  9025. C D#+nnn#+mmm etc for Display cells relative to our current display
  9026. C location as held in the DROW,DCOL cells in commons.
  9027. C ***<<<< RDD COMMON START >>>***
  9028.     InTeGer*4 RRWACT,RCLACT
  9029. C    COMMON/RCLACT/RRWACT,RCLACT
  9030.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  9031.      1  IDOL7,IDOL8
  9032. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  9033. C     1  IDOL7,IDOL8
  9034.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  9035. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  9036.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  9037. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  9038. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  9039. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  9040.     InTeGer*4 KLVL
  9041. C    COMMON/KLVL/KLVL
  9042.     InTeGer*4 IOLVL,IGOLD
  9043. C    COMMON/IOLVL/IOLVL
  9044. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  9045. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  9046.     Integer*4 k3dfg,kcdelt,krdelt,kshtf
  9047.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  9048.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  9049.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  9050.      3  k3dfg,kcdelt,krdelt,kshtf
  9051. C ***<<< RDD COMMON END >>>***
  9052. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6
  9053. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6
  9054. CCC    InTeGer*4 PROW,PCOL
  9055. C ! PHYSICAL ROW, COL BEING HANDLED.
  9056. CCC    InTeGer*4 DROW,DCOL,DCLV,DRWV
  9057.     InTeGer*4 RSM,CSM,AFG,ASM,VCF,CH
  9058. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  9059.     LOGICAL*4 L1,L2
  9060. C    LOGICAL*2 L63,L192,L127
  9061.     InTeGer*4 I1,I2
  9062.     InTeGer*4 I63,I192,I127
  9063.     EQUIVALENCE(I1,L1),(I2,L2)
  9064. C    EQUIVALENCE (I63,L63),(I192,L192),(L127,I127)
  9065.     DATA I63/63/,I192/192/,I127/127/
  9066. C DRWV,DCLV = # OF MAX ROWS, COLS ACTUALLY ON SCREEN NOW. DROW,DCOL
  9067. C ARE ACTUAL "CURSOR" LOCATION.
  9068. C
  9069. C ZERO OUR VARIABLES
  9070.     LPFG=0
  9071. C ! FLAG WE GOT A LOGICAL/PHYSICAL # FORM AND TYPE
  9072.     AFG=0
  9073. C ! FLAG WE SAW AN ALPHA
  9074.     ASM=0
  9075. C ! SUM OF ALPHAS HASHCODED (ACCUMULATOR)
  9076.     NSM=0
  9077. C ! ACCUMULATOR FOR NUMERICS
  9078.     NFG=0
  9079. C ! FLAG WE SAW A NUMERIC
  9080.     RSM=0
  9081. C ! AC FOR ROWS IN # FORMS
  9082.     CSM=0
  9083. C ! AC FOR COLS IN # FORMS
  9084.     ISPC=0
  9085. C ! COUNTER FOR NONSPACES SEEN (USED TO STOP ON TRAILING SPACES)
  9086.     ktpnd=0
  9087.     idol1=0
  9088.     idol2=0
  9089.     IF(LINE(IBGN).NE.'%')GOTO 2000
  9090.     ID1=27
  9091.     ID2=1
  9092.     IVALID=1
  9093.     LSTCHR=IBGN+1
  9094. C SPECIAL CASE FOR % = AC #27
  9095.     RETURN
  9096. 2000    CONTINUE
  9097.     DO 1 N=IBGN,LEND
  9098.     VCF=0
  9099.     LSTCHR=N
  9100.     CH=ICHAR(LINE(N))
  9101.     IF (CH.EQ.255)GOTO 5000
  9102. C 5000 DECODES ENCODED FORMS AND RETURNS THEM...
  9103. C
  9104. C IGNORE SPACES AND TABS IF LEADING
  9105.     IF(CH.GT.32)ISPC=ISPC+1
  9106.     IF(CH.GT.0.AND.CH.LE.32.AND.ISPC.EQ.0)GOTO 1
  9107. C SPECIAL CASE TRAILING DOLLAR SIGNS... SKIP AND FLAG
  9108.     IF(CH.NE.36)GOTO 3443
  9109. C 36 IS ASCII FOR $ SIGN
  9110. C SAW A DOLLAR SIGN
  9111.     IF(AFG.EQ.1.AND.NFG.EQ.0)IDOL1=1
  9112.     IF(AFG.EQ.1.AND.NFG.EQ.1)IDOL2=1
  9113. C LEAVES WITH IDOL1 FLAGGED AS 1 IF LETTER PART WAS FOLLOWED BY
  9114. C DOLLAR SIGN, AND IDOL2 FLAGGED IF NUMBER PART WAS FOLLOWED
  9115. C BY DOLLAR. IGNORES ALL OTHER DOLLAR SIGNS.
  9116.     GOTO 1
  9117. 3443    CONTINUE
  9118. C GET CHARACTER VALUE IN.
  9119. C MUST BE UPPERCASE.
  9120.     IF(.NOT.(CH.GE.65.AND.CH.LT.91)) GOTO 100
  9121. C CH IS AN ALPHA, RANGE A-Z
  9122.     VCF=1
  9123. C ! VALID CHAR SEEN
  9124.     AFG=1
  9125. C !SAW THE ALPHA
  9126.     IF(ASM.LT.MRC)ASM=(CH-64)+26*ASM
  9127.     IF(NFG.NE.0)GOTO 103
  9128. C FILTER OUT TOO-LARGE VALUES...
  9129. C leave the 18000 limit in for now; seems big enough!
  9130.     IF(ASM.GT.(mrc-MCols))GOTO 103
  9131. C 60 * 26 IS LIM ABOVE
  9132.     IF(CH.EQ.80)LPFG=1
  9133. C ! FLAG WE GOT PHYS. FORM MAYBE
  9134.     IF(CH.EQ.68)LPFG=2
  9135. C ! FLAG WE GOT DISPLAY FORM MAYBE
  9136. 100    CONTINUE
  9137. C EXPECT # FORMS TO HAVE # JUST AFTER 1ST ALPHA.
  9138. C 35 IS ASCII VALUE OF '#' CHAR.
  9139.     IF(CH.EQ.35)GOTO 1000
  9140. C NEXT TEST NUMERICS
  9141.     IF(.NOT.(CH.GE.48.AND.CH.LE.57))GOTO 101
  9142. C CH IS A NUMERIC, RANGE 0-9
  9143.     VCF=1
  9144. C ! VALID CHAR SEEN
  9145.     NFG=1
  9146. C ! FLAG WE SAW NUMERIC
  9147.     IF(AFG.NE.0)GOTO 102
  9148.     GOTO 103
  9149. 102    CONTINUE
  9150.     IF(NSM.LT.MRC)NSM=(CH-48)+10*NSM
  9151. C FILTER OUT TOO-LARGE VALUES EARLY
  9152. C 301 * 10 IS LIMIT...
  9153.     IF(NSM.GT.(MRC-MCols))GOTO 103
  9154. C ! CONVERT CHARS TO BINARY AS SEEN
  9155. 101    CONTINUE
  9156.     IF(VCF.EQ.0)GOTO 2
  9157. C !END ON ANY INVALID CHARACTER
  9158. 1    CONTINUE
  9159. 2    CONTINUE
  9160.     IF(AFG.EQ.0)GOTO 103
  9161.     GOTO 950
  9162. 103    CONTINUE
  9163. C INVALID ... NUMERIC AND NO PRIOR ALPHA. FLAG BAD NAME AND EXIT.
  9164.     IVALID=0
  9165.     RETURN
  9166. 950    ID1=ASM
  9167.     ID2=1+NSM
  9168. C ! NOTE ID2=1 IF NO NUMERICS SEEN, MORE OTHERWISE.
  9169.     GOTO 1201
  9170. 1000    CONTINUE
  9171. C HERE HANDLE CURRENT-REFERENCED FORMS USING # AS SPECIAL CHARACTER MEANING
  9172. C THE CURRENT POSITION. THESE TYPES OF REFERENCES MAY BE MOVED AROUND THE
  9173. C SHEET WHICH ACCOUNTS FOR THEIR USEFULNESS. SINCE THERE IS A DISPLAY
  9174. C AND PHYSICAL SHEET WHICH ARE MAPPED BY A MAPPING, ALLOW EITHER
  9175. C TO BE REFERENCED. THUS, COMPLEX CALCULATIONS MAY BE DONE BUT LARGELY
  9176. C HIDDEN. THE ACCUMULATORS MAY BE USED AS SCRATCH STORAGE FOR THIS
  9177. C SORT OF THING.
  9178. C SAW THE # SIGN, SO SEE IF THE + OR - N CAN BE DECODED.
  9179. C IF NO P OR D WAS SEEN HOWEVER WE HAVE AN INVALID NAME, SO FLAG IT.
  9180.     IF(LPFG.EQ.0)GOTO 103
  9181. C PASS THE # SIGN PRIOR TO GETTING THE NUMERIC.
  9182.     LSTCHR=LSTCHR+1
  9183.     iundr=0
  9184.     if(line(lstchr).eq.'_')iundr=1
  9185.     if(line(lstchr).eq.'$')iundr=2
  9186.     if(line(lstchr).ne.'%'.and.iundr.eq.0)goto 3900
  9187. c allow p#%ab form to mean use ac a and b to get offsets from "here"
  9188. c allow P#_ab to be absolute address ref for cells (otherwise like p#%ab)
  9189.     CSM=0
  9190.     RSM=0
  9191. C DEFAULT TO "THIS" CELL
  9192.     LSTCHR=LSTCHR+1
  9193. C PASS THE % SIGN (or other special char we recognize)
  9194.     if(Iundr.lt.2)goto 3906
  9195. c
  9196. c P#$var1var2 is a form that allows relative addressing using ANY of the
  9197. c cells for col and row. First cell is col, 2nd is row
  9198. c The pointers so derived are ABSOLUTE, relative to absolute beginning of
  9199. c the sheet. This seems to me more useful than the relative addressing forms.
  9200. c However, I dislike the offset by 1 for rows so will subtract it off so the
  9201. c accumulators will be addressed as row 0.
  9202.     kkk=lstchr
  9203.     kkkk=lstchr+20
  9204.     klstc=kkk
  9205. c
  9206. c Call copy (without this mod) of varscn subroutine to do the examining of 
  9207. c variable names, so we don't wind up recursively calling ourselves.
  9208. c
  9209.     call varsc2(line,kkk,kkkk,klstc,kr1,kr2,kvld)
  9210.     if(kvld.eq.0)goto 3906
  9211. c try normal processing if this doesn't look like regular variables
  9212.     if(line(klstc).eq.':')klstc=klstc+1
  9213.     kkk=klstc
  9214.     kkkk=kkk+20
  9215.     call varsc2(line,kkk,kkkk,klstc,kc1,kc2,kvld)
  9216.     if(kvld.eq.0)goto 3906
  9217. c Update last chharacter seen pointer to pass these variables.
  9218.     if(line(klstc).eq.':')klstc=klstc+1
  9219.     lstchr=klstc
  9220. c Get the values of the variables and store as integers
  9221.     call xvblgt(kr1,kr2,xac)
  9222.     rsm=xac
  9223.     call xvblgt(kc1,kc2,xac)
  9224.     csm=xac
  9225.     goto 3901
  9226. 3906    continue
  9227.     RSM=ICHAR(LINE(LSTCHR))
  9228.     CSM=ICHAR(LINE(LSTCHR+1))
  9229.     LSTCHR=LSTCHR+2
  9230. C FIX UP ASCII OFFSETS, AND MEANWHILE REQUIRE UPPERCASE
  9231. C AND THAT THERE BE 2 AC'S NAMES AFTER THE %.
  9232. C THIS SHOULD BE HANDY FOR COMMAND FILES.
  9233.     RSM=RSM-64
  9234.     CSM=CSM-64
  9235. C NOW RSM, CSM ARE SUBSCRIPTS. PULL OUT VALUES FROM XVBLS
  9236.     IF(RSM.LE.0.OR.RSM.GT.27)GOTO 103
  9237.     IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
  9238.     DO 3902 IV=1,8
  9239. 3902    XAV1(IV)=AVBLS(IV,RSM)
  9240.     RSM=XAVB
  9241.     DO 3903 IV=1,8
  9242. 3903    XAV1(IV)=AVBLS(IV,CSM)
  9243.     CSM=XAVB
  9244. C LOADS THE 2 AC'S TO THE OFFSETS AND GOES ON...JUST NEEDS THE
  9245. C 2 LETTERS AFTER P#% OR D#%.
  9246.     goto 3901
  9247. 3900    continue
  9248.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9249. C GN GETS THE +- NN NUMBER AND RETURNS VALUE IN NUM.
  9250. C LSTCHR RETURNS AS NEXT CHAR NOT USED.
  9251.     RSM=NUM
  9252. C 35 IS ASCII FOR '#'
  9253. C allow any delimiter between numbers, though we must have # at start
  9254. C  to delimit valid relative coordinates.
  9255. C    IF(ICHAR(LINE(LSTCHR)).NE.35) GOTO 103
  9256. C IF NO SECOND # SEEN, THE FORM IS INVALID SO SAY SO AND EXIT.
  9257.     LSTCHR=MIN0(LSTCHR+1,LEND)
  9258. CC BUMP PAST THE # IF WE SAW IT.
  9259. C now get the second numeric string and bump LSTCHR past it.
  9260.     NUM=0
  9261.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9262.     CSM=NUM
  9263. C NOW HAVE THE NUMBERS ENCODED. NOTE THAT ## IS VALID.
  9264. 3901    CONTINUE
  9265.     IF(LPFG.EQ.2) GOTO 1200
  9266. C IF HERE, LPFG=1 AND WE ARE ON PHYSICAL SHEET.
  9267.     if(Iundr.ne.0)goto 3908
  9268.     ID2=CSM+PCOL
  9269.     ID1=RSM+PROW
  9270.     goto 1201
  9271. 3908    Continue
  9272.     id2=CSM+1
  9273.     id1=RSM
  9274. c Subtract 1 from row to make accumulator row be number zero. This is more
  9275. c symmetrical with other usages in the sheet cell names. I like it better than
  9276. c making cell A1 be col 1 row 2.
  9277. 1201    CONTINUE
  9278. C Add-in for 3d cells
  9279.     kshtf=0
  9280.     If(k3dfg.lt.0)goto 1202
  9281. C 37 is ascii %
  9282.     IF(LINE(LSTCHR).NE.'%') GOTO 1202
  9283. C pass the trailing % character now
  9284.     LSTCHR=MIN0(LSTCHR+1,LEND)
  9285. C limited form of syntax: either a number is to be used
  9286. C or an accumulator.
  9287.     If(ichar(line(lstchr)).gt.64) goto 1203
  9288. C a number.
  9289.     NUM=0
  9290.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9291.     CSM=NUM
  9292.     Goto 1204
  9293. 1203    Continue
  9294. C a (possible) accumulator
  9295.     csm=ichar(line(lstchr))
  9296.     LSTCHR=MIN0(LSTCHR+1,LEND)
  9297.     CSM=CSM-64
  9298. C Csm now is index to accumulator. Validity check it.
  9299.     IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
  9300.     DO 2902 IV=1,8
  9301. 2902    XAV1(IV)=AVBLS(IV,csm)
  9302. C convert the accumulator value.
  9303.     CSM=XAVB
  9304. 1204    Continue
  9305. C now fix up the col and row returned.
  9306.     id1=id1+(csm*kcdelt)
  9307.     id2=id2+(csm*krdelt)
  9308.     kshtf=csm
  9309. C allow our callers to see what (if any) "page" was flagged.
  9310. C note that zero and no page flagged are treated the same.
  9311. 1202    Continue
  9312. C TO ALLOW REFLECTED VALUES TO WORK, LET ALL NORMAL VALUES BY...
  9313. C    IF(ID1.GT.60.OR.ID1.LE.0)GOTO 103
  9314. C    IF(ID2.GT.301.OR.ID2.LE.0)GOTO 103
  9315.     IVALID=1
  9316. C ALL IS WELL
  9317.     RETURN
  9318. 1200    CONTINUE
  9319. C DISPLAY COLUMN RELATIVE.
  9320.     DLFG=1
  9321. C FLAG WE SAW A D## FORM FOR RECALC
  9322.     DRRW=DROW+RSM
  9323.     DRRW=MAX0(1,DRRW)
  9324.     DRRW=MIN0(20,DRRW)
  9325.     DCCL=DCOL+CSM
  9326. C ENSURE DISPLAY COORDS IN LEGAL BOUNDS
  9327.     DCCL=MAX0(1,DCCL)
  9328.     DCCL=MIN0(75,DCCL)
  9329. C CLAMP TO WITHIN LEGAL DIMENSIONS.
  9330.     ID1=NRDSP(DRRW,DCCL)
  9331.     ID2=NCDSP(DRRW,DCCL)
  9332.     GOTO 1201
  9333. 5000    CONTINUE
  9334.     IF(ASM.NE.0.OR.NSM.NE.0)GOTO 103
  9335. C HANDLE 255,CODE1,CODE2 FORMS
  9336. C FIRST BYTE IS ALWAYS 255
  9337. C 2ND BYTE IS: HI 2 BITS ARE HI 2 BITS OF ID2. LO 6 BITS ARE ID1
  9338. C 3RD BYTE IS: LO 8 BITS OF ID2
  9339.     I1=ICHAR(LINE(LSTCHR+1))
  9340.     I2=IMASK(I1,I192)
  9341. C    L2=L1.AND.L192
  9342. C    L1=L1.AND.L63
  9343.     I1=IMASK(I1,I63)
  9344.     ID1=I1
  9345.     I1=ICHAR(LINE(LSTCHR+2))
  9346. C    L1=L1.AND.L127
  9347.     I1=IMASK(I1,I127)
  9348. C MUST HAVE 128 BIT ON IN LOW BYTE TO AVOID NULLS IN IT.
  9349.     ID2=I2*2+I1
  9350.     LSTCHR=LSTCHR+3
  9351.     GOTO 1201
  9352.     END
  9353. c -h- varsc2.for
  9354. C $DO66
  9355.     SUBROUTINE VARSC2(LINE,IBGN,LEND,LSTCHR,ID1,ID2,IVALID)
  9356.     Include AParms.inc
  9357. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  9358. C ALL RIGHTS RESERVED
  9359. C
  9360. C VARSC2 - SCAN COMMAND LINE FOR VARIABLE NAMES.
  9361. C    This copy of VARSCN lacks the P#@var1var2 construct and exists to
  9362. C    be called from VARSCN for that construct to parse the var1 and var2
  9363. C    variable names without risk of a recursive call to varscn (which
  9364. C    Fortran generally cannot handle.)
  9365. C
  9366. C    SCANS FOR VARIABLE NAMES OF FORM AAANNN WHERE AAA = LETTERS
  9367. C BETWEEN A AND Z UP TO NON-ALPHA, CORRESPONDING TO ROW, FOLLOWED BY
  9368. C NUMBERS IN THE 0-9 RANGE MAKING A DECIMAL COLUMN NUMBER.
  9369. C
  9370. C THE LETTERS ARE FORMED BY
  9371. C A-Z ALONE GIVE ROW 1-26, COL 1. % IS ROW 27,COL1
  9372. C A1-Z1 GIVE ROW 1-26, COL 2
  9373. C AA1-ZZ1 ARE ROW 27-52, COL 2
  9374.     IMPLICIT InTeGer*4 (A-Z)
  9375. C NOTE COL 1 IS DUMMY. DISPLAY THE SHEET SIDEWAYS SO WE GET USUAL VISUAL
  9376. C ROWS, COLS., AND ACCUMULATORS A-Z,% JUST APPEAR AS A FICTITIOUS ROW 0
  9377. C ON DISPLAY, INSTEAD OF REAL COLUMN 1 HERE.
  9378.     DIMENSION LINE(LEND)
  9379.     CHARACTER*1 LINE
  9380.     InTeGer*4 TYPE(1,1),VLEN(9)
  9381.     REAL*8 XVBLS(1,1)
  9382.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  9383.     REAL*8 XAVB
  9384.     REAL*4 XAV2(2)
  9385.     CHARACTER*1 XAV1(8)
  9386.     EXTERNAL INDX
  9387.     EQUIVALENCE(XAVB,XAV2(1)),(XAVB,XAV1(1))
  9388.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  9389.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  9390. C ***<<< KLSTO COMMON START >>>***
  9391.     InTeGer*4 DLFG
  9392. C    COMMON/DLFG/DLFG
  9393.     InTeGer*4 KDRW,KDCL
  9394. C    COMMON/DOT/KDRW,KDCL
  9395.     InTeGer*4 DTRENA
  9396. C    COMMON/DTRCMN/DTRENA
  9397.     REAL*8 EP,PV,FV
  9398.     DIMENSION EP(20)
  9399.     INTEGER*4 KIRR
  9400. C    COMMON/ERNPER/EP,PV,FV,KIRR
  9401.     InTeGer*4 LASTOP
  9402. C    COMMON/ERROR/LASTOP
  9403.     CHARACTER*1 FMTDAT(9,76)
  9404. C    COMMON/FMTBFR/FMTDAT
  9405.     CHARACTER*1 EDNAM(16)
  9406. C    COMMON/EDNAM/EDNAM
  9407.     InTeGer*4 MFID(2),MFMOD(2)
  9408. C    COMMON/FRM/MFID,MFMOD
  9409.     InTeGer*4 JMVFG,JMVOLD
  9410. C    COMMON/FUBAR/JMVFG,JMVOLD
  9411.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  9412.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  9413. C ***<<< KLSTO COMMON END >>>***
  9414. CCC    InTeGer*4 DLFG
  9415. CCC    COMMON/DLFG/DLFG
  9416. C DLFG=1 IF D## FORMS ARE SEEN
  9417.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  9418.     COMMON/D2R/NRDSP,NCDSP
  9419. C NRDSP AND NCDSP ARE REAL ROW, COL OF DISPLAY ROW, COL CELLS. NOTE THAT
  9420. C NOT ALL DISPLAY CELLS ARE ALWAYS ACTUALLY SHOWN; ONLY THOSE THAT FIT
  9421. C ARE SHOWN; THE REST "EXIST" BUT DON'T APPEAR UNLESS ROWS ARE SMALL
  9422. C ENOUGH.
  9423. C
  9424. C THIS PROGRAM ALSO HANDLES CELL SPECS OF FORM
  9425. C P#+nnn#+nnn (or P#-nnn#-mmm) FOR Physical cells relative to our current
  9426. C physical cell on the sheet (clamped at boundaries), or of form
  9427. C D#+nnn#+mmm etc for Display cells relative to our current display
  9428. C location as held in the DROW,DCOL cells in commons.
  9429. C ***<<<< RDD COMMON START >>>***
  9430.     InTeGer*4 RRWACT,RCLACT
  9431. C    COMMON/RCLACT/RRWACT,RCLACT
  9432.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  9433.      1  IDOL7,IDOL8
  9434. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  9435. C     1  IDOL7,IDOL8
  9436.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  9437. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  9438.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  9439. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  9440. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  9441. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  9442.     InTeGer*4 KLVL
  9443. C    COMMON/KLVL/KLVL
  9444.     InTeGer*4 IOLVL,IGOLD
  9445. C    COMMON/IOLVL/IOLVL
  9446. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  9447. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  9448.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  9449.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  9450.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  9451.      3  k3dfg,kcdelt,krdelt,kpag
  9452. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  9453. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  9454. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  9455. C ***<<< RDD COMMON END >>>***
  9456. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6
  9457. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6
  9458. CCC    InTeGer*4 PROW,PCOL
  9459. C ! PHYSICAL ROW, COL BEING HANDLED.
  9460. CCC    InTeGer*4 DROW,DCOL,DCLV,DRWV
  9461.     InTeGer*4 RSM,CSM,AFG,ASM,VCF,CH
  9462. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  9463.     LOGICAL*4 L1,L2
  9464. C    LOGICAL*2 L63,L192,L127
  9465.     InTeGer*4 I1,I2
  9466.     InTeGer*4 I63,I192,I127
  9467.     EQUIVALENCE(I1,L1),(I2,L2)
  9468. C    EQUIVALENCE (I63,L63),(I192,L192),(L127,I127)
  9469.     DATA I63/63/,I192/192/,I127/127/
  9470. C DRWV,DCLV = # OF MAX ROWS, COLS ACTUALLY ON SCREEN NOW. DROW,DCOL
  9471. C ARE ACTUAL "CURSOR" LOCATION.
  9472. C
  9473. C ZERO OUR VARIABLES
  9474.     LPFG=0
  9475. C ! FLAG WE GOT A LOGICAL/PHYSICAL # FORM AND TYPE
  9476.     AFG=0
  9477. C ! FLAG WE SAW AN ALPHA
  9478.     ASM=0
  9479. C ! SUM OF ALPHAS HASHCODED (ACCUMULATOR)
  9480.     NSM=0
  9481. C ! ACCUMULATOR FOR NUMERICS
  9482.     NFG=0
  9483. C ! FLAG WE SAW A NUMERIC
  9484.     RSM=0
  9485. C ! AC FOR ROWS IN # FORMS
  9486.     CSM=0
  9487. C ! AC FOR COLS IN # FORMS
  9488.     ISPC=0
  9489. C ! COUNTER FOR NONSPACES SEEN (USED TO STOP ON TRAILING SPACES)
  9490.     idol1=0
  9491.     idol2=0
  9492.     IF(LINE(IBGN).NE.'%')GOTO 2000
  9493.     ID1=27
  9494.     ID2=1
  9495.     IVALID=1
  9496.     LSTCHR=IBGN+1
  9497. C SPECIAL CASE FOR % = AC #27
  9498.     RETURN
  9499. 2000    CONTINUE
  9500.     DO 1 N=IBGN,LEND
  9501.     VCF=0
  9502.     LSTCHR=N
  9503.     CH=ICHAR(LINE(N))
  9504.     IF (CH.EQ.255)GOTO 5000
  9505. C 5000 DECODES ENCODED FORMS AND RETURNS THEM...
  9506. C
  9507. C IGNORE SPACES AND TABS IF LEADING
  9508.     IF(CH.GT.32)ISPC=ISPC+1
  9509.     IF(CH.GT.0.AND.CH.LE.32.AND.ISPC.EQ.0)GOTO 1
  9510. C SPECIAL CASE TRAILING DOLLAR SIGNS... SKIP AND FLAG
  9511.     IF(CH.NE.36)GOTO 3443
  9512. C 36 IS ASCII FOR $ SIGN
  9513. C SAW A DOLLAR SIGN
  9514.     IF(AFG.EQ.1.AND.NFG.EQ.0)IDOL1=1
  9515.     IF(AFG.EQ.1.AND.NFG.EQ.1)IDOL2=1
  9516. C LEAVES WITH IDOL1 FLAGGED AS 1 IF LETTER PART WAS FOLLOWED BY
  9517. C DOLLAR SIGN, AND IDOL2 FLAGGED IF NUMBER PART WAS FOLLOWED
  9518. C BY DOLLAR. IGNORES ALL OTHER DOLLAR SIGNS.
  9519.     GOTO 1
  9520. 3443    CONTINUE
  9521. C GET CHARACTER VALUE IN.
  9522. C MUST BE UPPERCASE.
  9523.     IF(.NOT.(CH.GE.65.AND.CH.LT.91)) GOTO 100
  9524. C CH IS AN ALPHA, RANGE A-Z
  9525.     VCF=1
  9526. C ! VALID CHAR SEEN
  9527.     AFG=1
  9528. C !SAW THE ALPHA
  9529.     IF(ASM.LT.MRC)ASM=(CH-64)+26*ASM
  9530.     IF(NFG.NE.0)GOTO 103
  9531. C FILTER OUT TOO-LARGE VALUES...
  9532.     IF(ASM.GT.(MRC-MCOls))GOTO 103
  9533. C 60 * 26 IS LIM ABOVE
  9534.     IF(CH.EQ.80)LPFG=1
  9535. C ! FLAG WE GOT PHYS. FORM MAYBE
  9536.     IF(CH.EQ.68)LPFG=2
  9537. C ! FLAG WE GOT DISPLAY FORM MAYBE
  9538. 100    CONTINUE
  9539. C EXPECT # FORMS TO HAVE # JUST AFTER 1ST ALPHA.
  9540. C 35 IS ASCII VALUE OF '#' CHAR.
  9541.     IF(CH.EQ.35)GOTO 1000
  9542. C NEXT TEST NUMERICS
  9543.     IF(.NOT.(CH.GE.48.AND.CH.LE.57))GOTO 101
  9544. C CH IS A NUMERIC, RANGE 0-9
  9545.     VCF=1
  9546. C ! VALID CHAR SEEN
  9547.     NFG=1
  9548. C ! FLAG WE SAW NUMERIC
  9549.     IF(AFG.NE.0)GOTO 102
  9550.     GOTO 103
  9551. 102    CONTINUE
  9552.     IF(NSM.LT.MRC)NSM=(CH-48)+10*NSM
  9553. C FILTER OUT TOO-LARGE VALUES EARLY
  9554. C 301 * 10 IS LIMIT...
  9555.     IF(NSM.GT.(MRC-MCols))GOTO 103
  9556. C ! CONVERT CHARS TO BINARY AS SEEN
  9557. 101    CONTINUE
  9558.     IF(VCF.EQ.0)GOTO 2
  9559. C !END ON ANY INVALID CHARACTER
  9560. 1    CONTINUE
  9561. 2    CONTINUE
  9562.     IF(AFG.EQ.0)GOTO 103
  9563.     GOTO 950
  9564. 103    CONTINUE
  9565. C INVALID ... NUMERIC AND NO PRIOR ALPHA. FLAG BAD NAME AND EXIT.
  9566.     IVALID=0
  9567.     RETURN
  9568. 950    ID1=ASM
  9569.     ID2=1+NSM
  9570. C ! NOTE ID2=1 IF NO NUMERICS SEEN, MORE OTHERWISE.
  9571.     GOTO 1201
  9572. 1000    CONTINUE
  9573. C HERE HANDLE CURRENT-REFERENCED FORMS USING # AS SPECIAL CHARACTER MEANING
  9574. C THE CURRENT POSITION. THESE TYPES OF REFERENCES MAY BE MOVED AROUND THE
  9575. C SHEET WHICH ACCOUNTS FOR THEIR USEFULNESS. SINCE THERE IS A DISPLAY
  9576. C AND PHYSICAL SHEET WHICH ARE MAPPED BY A MAPPING, ALLOW EITHER
  9577. C TO BE REFERENCED. THUS, COMPLEX CALCULATIONS MAY BE DONE BUT LARGELY
  9578. C HIDDEN. THE ACCUMULATORS MAY BE USED AS SCRATCH STORAGE FOR THIS
  9579. C SORT OF THING.
  9580. C SAW THE # SIGN, SO SEE IF THE + OR - N CAN BE DECODED.
  9581. C IF NO P OR D WAS SEEN HOWEVER WE HAVE AN INVALID NAME, SO FLAG IT.
  9582.     IF(LPFG.EQ.0)GOTO 103
  9583. C PASS THE # SIGN PRIOR TO GETTING THE NUMERIC.
  9584.     LSTCHR=LSTCHR+1
  9585.     iundr=0
  9586.     if(line(lstchr).eq.'_')iundr=1
  9587.     if(line(lstchr).ne.'%'.and.iundr.eq.0)goto 3900
  9588. c allow p#%ab form to mean use ac a and b to get offsets from "here"
  9589. c allow P#_ab to be absolute address ref for cells (otherwise like p#%ab)
  9590.     CSM=0
  9591.     RSM=0
  9592. C DEFAULT TO "THIS" CELL
  9593.     LSTCHR=LSTCHR+1
  9594. C PASS THE % SIGN
  9595.     RSM=ICHAR(LINE(LSTCHR))
  9596.     CSM=ICHAR(LINE(LSTCHR+1))
  9597.     LSTCHR=LSTCHR+2
  9598. C FIX UP ASCII OFFSETS, AND MEANWHILE REQUIRE UPPERCASE
  9599. C AND THAT THERE BE 2 AC'S NAMES AFTER THE %.
  9600. C THIS SHOULD BE HANDY FOR COMMAND FILES.
  9601.     RSM=RSM-64
  9602.     CSM=CSM-64
  9603. C NOW RSM, CSM ARE SUBSCRIPTS. PULL OUT VALUES FROM XVBLS
  9604.     IF(RSM.LE.0.OR.RSM.GT.27)GOTO 103
  9605.     IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
  9606.     DO 3902 IV=1,8
  9607. 3902    XAV1(IV)=AVBLS(IV,RSM)
  9608.     RSM=XAVB
  9609.     DO 3903 IV=1,8
  9610. 3903    XAV1(IV)=AVBLS(IV,CSM)
  9611.     CSM=XAVB
  9612. C LOADS THE 2 AC'S TO THE OFFSETS AND GOES ON...JUST NEEDS THE
  9613. C 2 LETTERS AFTER P#% OR D#%.
  9614.     goto 3901
  9615. 3900    continue
  9616.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9617. C GN GETS THE +- NN NUMBER AND RETURNS VALUE IN NUM.
  9618. C LSTCHR RETURNS AS NEXT CHAR NOT USED.
  9619.     RSM=NUM
  9620. C 35 IS ASCII FOR '#'
  9621. C allow any delimiter between numbers, though we must have # at start
  9622. C  to delimit valid relative coordinates.
  9623. C    IF(ICHAR(LINE(LSTCHR)).NE.35) GOTO 103
  9624. C IF NO SECOND # SEEN, THE FORM IS INVALID SO SAY SO AND EXIT.
  9625.     LSTCHR=MIN0(LSTCHR+1,LEND)
  9626. CC BUMP PAST THE # IF WE SAW IT.
  9627. C now get the second numeric string and bump LSTCHR past it.
  9628.     NUM=0
  9629.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9630.     CSM=NUM
  9631. C NOW HAVE THE NUMBERS ENCODED. NOTE THAT ## IS VALID.
  9632. 3901    CONTINUE
  9633.     IF(LPFG.EQ.2) GOTO 1200
  9634. C IF HERE, LPFG=1 AND WE ARE ON PHYSICAL SHEET.
  9635.     if(Iundr.eq.1)goto 3908
  9636.     ID2=CSM+PCOL
  9637.     ID1=RSM+PROW
  9638.     goto 1201
  9639. 3908    Continue
  9640.     id2=CSM
  9641.     id1=RSM
  9642. 1201    CONTINUE
  9643. C TO ALLOW REFLECTED VALUES TO WORK, LET ALL NORMAL VALUES BY...
  9644. C    IF(ID1.GT.60.OR.ID1.LE.0)GOTO 103
  9645. C    IF(ID2.GT.301.OR.ID2.LE.0)GOTO 103
  9646.     IVALID=1
  9647. C ALL IS WELL
  9648.     RETURN
  9649. 1200    CONTINUE
  9650. C DISPLAY COLUMN RELATIVE.
  9651.     DLFG=1
  9652. C FLAG WE SAW A D## FORM FOR RECALC
  9653.     DRRW=DROW+RSM
  9654.     DRRW=MAX0(1,DRRW)
  9655.     DRRW=MIN0(20,DRRW)
  9656.     DCCL=DCOL+CSM
  9657. C ENSURE DISPLAY COORDS IN LEGAL BOUNDS
  9658.     DCCL=MAX0(1,DCCL)
  9659.     DCCL=MIN0(75,DCCL)
  9660. C CLAMP TO WITHIN LEGAL DIMENSIONS.
  9661.     ID1=NRDSP(DRRW,DCCL)
  9662.     ID2=NCDSP(DRRW,DCCL)
  9663.     GOTO 1201
  9664. 5000    CONTINUE
  9665.     IF(ASM.NE.0.OR.NSM.NE.0)GOTO 103
  9666. C HANDLE 255,CODE1,CODE2 FORMS
  9667. C FIRST BYTE IS ALWAYS 255
  9668. C 2ND BYTE IS: HI 2 BITS ARE HI 2 BITS OF ID2. LO 6 BITS ARE ID1
  9669. C 3RD BYTE IS: LO 8 BITS OF ID2
  9670.     I1=ICHAR(LINE(LSTCHR+1))
  9671.     I2=IMASK(I1,I192)
  9672. C    L2=L1.AND.L192
  9673. C    L1=L1.AND.L63
  9674.     I1=IMASK(I1,I63)
  9675.     ID1=I1
  9676.     I1=ICHAR(LINE(LSTCHR+2))
  9677. C    L1=L1.AND.L127
  9678.     I1=IMASK(I1,I127)
  9679. C MUST HAVE 128 BIT ON IN LOW BYTE TO AVOID NULLS IN IT.
  9680.     ID2=I2*2+I1
  9681.     LSTCHR=LSTCHR+3
  9682.     GOTO 1201
  9683.     END
  9684. c -h- vvary.for    Fri Aug 22 13:37:17 1986    
  9685. C $DO66
  9686. C VARY CONTROL ROUTINE
  9687. C NOTE: THIS ROUTINE RELIES UPON HAVING ITS DATA AREAS REMAIN INTACT
  9688. C ACROSS CALLS. IT MUST NOT BE IN AN OVERLAY SEGMENT OR THAT WILL FAIL
  9689. C AND IT WILL NOT WORK. SPECIFICALLY IT EXPECTS THE AC ARRAY TO BE
  9690. C SET CORRECTLY.
  9691.     SUBROUTINE VVARY(LINE,RETCD,K)
  9692.     CHARACTER*1 LINE(80)
  9693.     INTEGER RETCD
  9694.     CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
  9695.     InTeGer*4 TYPE(1,1),VLEN(9)
  9696.     REAL*8 XAC,XVBLS(1,1)
  9697.     EQUIVALENCE(XAC,AVBLS(1,27))
  9698.     INTEGER*4 JVBLS(2,1,1)
  9699.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  9700.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  9701.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  9702. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  9703. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  9704. C (IMPLEMENT FOR VAX ONLY)
  9705. C ***<<< XVXTCD COMMON START >>>***
  9706.     CHARACTER*1 OARRY(100)
  9707.     InTeGer*4 OSWIT,OCNTR
  9708. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  9709. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  9710. C    InTeGer*4 IPS1,IPS2,MODFLG
  9711.     InTeGer*4 IC1POS,IC2POS,MODFLG
  9712. CCC    COMMON/ICPOS/IC1POS,IC2POS,MODFLG
  9713. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  9714.        InTeGer*4 XTCFG,IPSET,XTNCNT
  9715.        CHARACTER*1 XTNCMD(80)
  9716. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  9717. C VARY FLAG ITERATION COUNT
  9718.     INTEGER KALKIT
  9719. C    COMMON/VARYIT/KALKIT
  9720.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  9721.     InTeGer*4 RCMODE,IRCE1,IRCE2
  9722. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  9723. C     1  IRCE2
  9724. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  9725. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  9726. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  9727. C RCFGX ON.
  9728. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  9729. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  9730. C  AND VM INHIBITS. (SETS TO 1).
  9731.     INTEGER*4 FH
  9732. C FILE HANDLE FOR CONSOLE I/O (RAW)
  9733. C    COMMON/CONSFH/FH
  9734.     CHARACTER*1 ARGSTR(52,4)
  9735. C    COMMON/ARGSTR/ARGSTR
  9736.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  9737.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  9738.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  9739.      3  IRCE2,FH,ARGSTR
  9740. C ***<<< XVXTCD COMMON END >>>***
  9741. CCC    INTEGER KALKIT
  9742. CCC    COMMON/VARYIT/KALKIT
  9743.     EXTERNAL SIGN
  9744.     INTEGER LPUT,LGET
  9745.     REAL*8 SIGN
  9746.     CHARACTER*1 LAC(8)
  9747.     REAL*8 XVAC,VW
  9748.     EQUIVALENCE(LAC(1),XVAC)
  9749.     REAL *8 AC(26)
  9750.     REAL*8 DERIV(8)
  9751.     REAL*8 DEL(8)
  9752.     REAL*8 OLDVV,OLDX,OLDA
  9753.     INTEGER ACV(8)
  9754.     INTEGER CAC
  9755.     INTEGER CCNT(8)
  9756. C UNCOMMENT THIS COMMON DECLARATION AND MOVE DATA STMTS INTO BLOCK
  9757. C IN ORDER TO OVERLAY THIS...
  9758.     COMMON/VRYDAT/AC,DERIV,DEL,CAC,CCNT,OLDVV,OLDX,OLDA,ACV
  9759. C
  9760. C ACV POINTS TO AC'S VARYING
  9761. C CAC = CURRENT INDEX INTO ACV TO FIND AC BEING VARIED
  9762. C AC IS LAST SET OF ACCUMULATORS SEEN
  9763. C IF ACV ENTRY IS 0, MEANS NO AC TO VARY THERE.
  9764.     INTEGER LW,LX,LI
  9765. C ! LOGICAL W,X,I AC'S
  9766.     INTEGER LA
  9767. C ! LOGICAL A AC
  9768. C
  9769. C    DATA DERIV/8*1./,DEL/8*0./
  9770. C    DATA CAC/1/,CCNT/8*0/
  9771. C    DATA ACV/8*0/
  9772. C    DATA OLDVV/1./
  9773. C
  9774. C PARSE ARGUMENTS FIRST
  9775. C FIRST 2 ARGS ARE X AND A AC'S (OR GENERAL CELLS)
  9776. C DEFAULT NO REDOING THIS...
  9777.     KALKIT=0
  9778.     IBGN=K+5
  9779.     LEND=IBGN+20
  9780.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LX,ID2A,IVALID)
  9781.     IF (IVALID.EQ.0)GOTO 9900
  9782.     IF(LINE(LSTCHR).NE.',')GOTO 9900
  9783.     IBGN=LSTCHR+1
  9784.     LEND=IBGN+20
  9785.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LA,ID2B,IVALID)
  9786.     IF (IVALID.EQ.0)GOTO 9900
  9787.     IF(LINE(LSTCHR).NE.',')GOTO 9900
  9788.     IBGN=LSTCHR+1
  9789.     LEND=IBGN+20
  9790.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LW,ID3B,IVALID)
  9791.     IF (IVALID.EQ.0)GOTO 9900
  9792.     IF(LINE(LSTCHR).NE.',')GOTO 9900
  9793.     IF(ID3B.NE.1)GOTO 9900
  9794.     IBGN=LSTCHR+1
  9795.     LEND=IBGN+20
  9796.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LI,ID3B,IVALID)
  9797.     IF (IVALID.EQ.0)GOTO 9900
  9798.     IF(LINE(LSTCHR).NE.',')GOTO 9900
  9799.     IF(ID3B.NE.1)GOTO 9900
  9800. C    IBGN=LSTCHR+1
  9801. C    LEND=IBGN+20
  9802. C LOOP OVER VALUES TO VARY NOW
  9803.     DO 99 N=1,8
  9804. 99    ACV(N)=0.
  9805.     DO 100 N=1,8
  9806. C ALLOW UP TO 8 DIMENSIONS VARIATION
  9807.     IBGN=LSTCHR+1
  9808.     LEND=IBGN+20
  9809.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ACV(N),ID3B,IVALID)
  9810.     IF (IVALID.EQ.0)GOTO 9900
  9811.     IF(LINE(LSTCHR).NE.';')GOTO 110
  9812.     IF(ID3B.NE.1)GOTO 9900
  9813.     IBGN=LSTCHR+1
  9814.     LEND=IBGN+20
  9815. 100    CONTINUE
  9816. 110    CONTINUE
  9817. C NOW HAVE ALL AC POINTERS SET UP.
  9818. C IF I IS NOW 0 OR NEGATIVE (ITER COUNT), REINITIALIZE.
  9819.     ASSIGN 111 TO LGET
  9820.     LLL=LI
  9821.     GOTO 500
  9822. 111    CONTINUE
  9823.     IF(XVAC.GT.0.)GOTO 112
  9824. C INITIALIZE COUNTS
  9825.     LLL=LW
  9826. C GET VALUE OF W FRACTION
  9827.     ASSIGN 114 TO LGET
  9828.     GOTO 500
  9829. 114    CONTINUE
  9830.     VW=XVAC
  9831.     OLDVV=1.
  9832.     DO 113 N=1,8
  9833.     CCNT(N)=0
  9834.     DERIV(N)=1.
  9835.     DEL(N)=VW
  9836. 113    CONTINUE
  9837.     CAC=1
  9838. C COPY CURRENT AC'S INTO SAVED ONES NOW.
  9839.     DO 117 N=1,26
  9840.     LLL=N
  9841.     ASSIGN 118 TO LGET
  9842.     GOTO 500
  9843. 118    AC(N)=XVAC
  9844. 117    CONTINUE
  9845. C AFTER THE INIT, JUST RETURN SINCE WE DON'T WANT TO TRY ANY ITERATIONS
  9846. C WHEN ITER COUNT EXPIRES.
  9847.     KALKIT=0
  9848.     RETURN
  9849. C HERE WHEN ITER COUNT IS POSITIVE.
  9850. 112    CONTINUE
  9851.     XVAC=XVAC-1.
  9852. C UPDATE ITERATION COUNT NOW...
  9853.     KALKIT=XVAC
  9854.     ASSIGN 120 TO LPUT
  9855.     GOTO 600
  9856. 120    CONTINUE
  9857. C
  9858. C NOW PROCEED WITH VARIATIONS...
  9859.     IF(CAC.LT.1.OR.CAC.GT.8)CAC=1
  9860.     IF(CCNT(CAC).GE.1)GOTO 200
  9861. C CCNT WAS 0 SO WE DIDN'T GET OUR PARTIAL YET. VARY THE
  9862. C AC WE'RE LOOKING AT (CAC = CURRENT AC) AND USE NEW VALUE OF
  9863. C (X-A) FOR A NUMERICAL DERIVATIVE RESULT AFTER A RECALC OF SCREEN...
  9864.     CCNT(CAC)=1
  9865. C JUST STARTED THIS AC SO VARY BY THE APPROPRIATE DELTA AND
  9866. C EXIT, ALLOWING PARTIAL TO BE COMPUTED NEXT TIME.
  9867.     LLL=LW
  9868.     ASSIGN 400 TO LGET
  9869.     GOTO 500
  9870. 400    CONTINUE
  9871. C GET W ACC. VALUE
  9872.     VW=XVAC
  9873.     IF(VW.EQ.0.)VW=.5
  9874. C GET CURRENT AC, FIND HOW TO UPDATE IT.
  9875.     LLL=ACV(CAC)
  9876.     IF(LLL.LE.0)GOTO 9900
  9877.     ASSIGN 121 TO LGET
  9878.     GOTO 500
  9879. 121    CONTINUE
  9880. C NOW XVAC HAS CURRENT AC FOR THE ONE WE'RE VARYING
  9881. C ADD DEL TO IT AND GET NEW ONE...
  9882. C SAVE OLD X AC VALUE FOR NEXT ITERATION.
  9883. C NOTE LLL IS STILL SET AT CURRENTLY VARYING AC
  9884. C SAVE CURRENT (UNVARIED) VALUE TOO FOR NEXT TIME AROUND.
  9885.     OLDVV=XVAC
  9886.     IF(OLDVV.EQ.0.)OLDVV=1.
  9887.     IF(DEL(CAC).EQ.0.)DEL(CAC)=VW
  9888.     XVAC=XVAC*(1.+DEL(CAC))
  9889. C NOW ALL SET... JUST SAVE CURRENT AC'S AND CURRENT X,A
  9890. C SO WE CAN GET DIFFERENCE NEXT TIME AROUND.
  9891. C    AC(ACV(CAC))=XVAC
  9892. C STORE XVAC INTO REAL ACCUMULATORS TOO, SO IT'LL WORK
  9893. C WHEN ALL AC'S ARE RELOADED BELOW.
  9894.     ASSIGN 412 TO LPUT
  9895.     GOTO 600
  9896. 412    CONTINUE
  9897. C AT 1000, RELOAD AC ARRAY FROM REAL AC'S... BUT GET OUR MODIFIED
  9898. C ONE WE JUST STORED TOO.
  9899.     GOTO 1000
  9900. 200    CONTINUE
  9901. C COUNT HERE IS 1 SO WE ALREADY HAVE INFO NOW FOR OUR PARITAL
  9902. C DERIVATIVE. COMPUTE IT AND VARY THE SELECTED AC USING IT
  9903. C THEN STORE IT AND RESET CCNT(CAC) TO 0
  9904.     CCNT(CAC)=0
  9905. C MUST GET NEW X AND A VALUES NOW.
  9906.     CALL XVBLGT(LX,ID2A,XVAC)
  9907. C    XVAC=XVBLS(LX,ID2A)
  9908.     IF(ID2A.NE.1)GOTO 201
  9909.     LLL=LX
  9910.     ASSIGN 201 TO LGET
  9911. C EXTRACT CURRENT X FROM AVBLS
  9912.     GOTO 500
  9913. 201    CONTINUE
  9914.     XCURR=XVAC
  9915.     CALL XVBLGT(LA,ID2B,XVAC)
  9916. C    XVAC=XVBLS(1,1)
  9917.     IF(ID2B.NE.1)GOTO 202
  9918.     LLL=LA
  9919.     ASSIGN 202 TO LGET
  9920.     GOTO 500
  9921. 202    CONTINUE
  9922.     ACURR=XVAC
  9923. C NOW WE HAVE ENOUGH TO COMPUTE PARTIAL DERIVATIVE WE NEED.
  9924.     IF(ACV(CAC).LE.0)GOTO 9900
  9925.     IF(OLDVV.EQ.0.)OLDVV=AC(ACV(CAC))
  9926.     IF(OLDVV.EQ.0.)OLDVV=1.
  9927.     DERIV(CAC)=((XCURR-ACURR)-(OLDX-OLDA))/(DEL(CAC)*OLDVV)
  9928. C NEGATIVE FEEDBACK: IF GOING POSITIVE, MAKE IT NEGATIVE...
  9929. C THIS IS NOT AN ANALYTICAL PROCEDURE ... JUST STEPS IN RIGHT DIRECTION
  9930. C BY APPROPRIATE AMOUNT AND CONTINUES...
  9931. C CLAMP VARIATION TO INITIAL PERCENTAGE IN W ACCUMULATOR
  9932.     LLL=LW
  9933. C OBTAIN VALUE OF W VARIATION NOW...IN CASE USER SETS IT UP TO VARY
  9934.     ASSIGN 203 TO LGET
  9935.     GOTO 500
  9936. 203    CONTINUE
  9937.     VW=XVAC
  9938. C
  9939. C TO ATTEMPT TO GET TO THE ZERO OF (X-A), WE REALLY NEED TO
  9940. C DIVIDE BY THE DERIVATIVE. HOWEVER, IN CASES WHERE THE FUNCTION
  9941. C IS NEAR ITS LOCAL MINIMUM AND SLOWLY VARYING, WE REALLY DON'T WANT
  9942. C TO STEP FAR AWAY (IT MAY NEVER REACH THE ZERO). THEREFORE, TEST
  9943. C TO SEE IF THE DERIVATIVE IS LARGE AND ALLOW DIVISION WHERE IT IS
  9944. C OVER A SOMEWHAT ARBITRARY THRESHOLD (USED 1.0 BELOW), BUT
  9945. C MULTIPLY BY DERIVATIVE OTHERWISE, SO THAT AS THE FUNCTION APPROACHES
  9946. C ZERO SLOPE, THE STEPS GET FINER TO GET INTO THE LOCAL MINIMUM (IF ANY).
  9947. C
  9948. C FORCE NONZERO VARIATION JUST SO WE DON'T GET STUCK.
  9949.     IF(DERIV(CAC).EQ.0.)DERIV(CAC)=.01
  9950.     IF(DABS(DERIV(CAC)).GT.1.)GOTO 405
  9951.     DEL(CAC)=-(OLDX-OLDA)*VW*DERIV(CAC)
  9952.     GOTO 406
  9953. 405    CONTINUE
  9954.     DEL(CAC)=-(OLDX-OLDA)*VW/DERIV(CAC)
  9955. 406    CONTINUE
  9956. C VERY IMPORTANT TO CLAMP SIZE OF STEPS HERE SO WE DON'T WILDLY DIVERGE
  9957. C IN EARLY GOING. SMALL STEPS TAKE LONGER BUT GET TO MINIMA; LARGER ONES
  9958. C WHERE WE DON'T KNOW FUNCTION SHAPE CAN BE DISASTERS.
  9959.     IF(DABS(DEL(CAC)).GT.VW)DEL(CAC)=VW*SIGN(DEL(CAC))
  9960. C NOW RESTORE AC'S TO OLD ONES AND VARY CURRENT ONE BY
  9961. C THE NEW DELTA.
  9962.     IF(ACV(CAC).LE.0)GOTO 9900
  9963. C NEXT LINE MAKES ADJUSTMENT NEEDED TO OUR VARYING AC.
  9964.     AC(ACV(CAC))=OLDVV*(1.+DEL(CAC))
  9965. C NOW COPY SAVED OLD AC'S ONTO NEW ONES SO WE START WITH AC'S ALL AS THEY
  9966. C WERE IN FIRST STEP SO WE VARY FROM INITIAL X, NOT FROM FIRST VARIED X
  9967. C LOCATION...
  9968.     DO 204 N=1,26
  9969.     XVAC=AC(N)
  9970.     LLL=N
  9971.     ASSIGN 205 TO LPUT
  9972.     GOTO 600
  9973. 205    CONTINUE
  9974. 204    CONTINUE
  9975. C MOVE ON TO THE NEXT CAC VALUE
  9976.     CAC=CAC+1
  9977.     IF(ACV(CAC).LE.0.OR.CAC.GT.8)CAC=1
  9978. 1000    CONTINUE
  9979. C SAVE OLD AC'S NOW FOR NEXT TIME
  9980.     DO 1100 N=1,26
  9981.     LLL=N
  9982.     ASSIGN 1101 TO LGET
  9983.     GOTO 500
  9984. 1101    AC(N)=XVAC
  9985. 1100    CONTINUE
  9986. C REMEMBER OLD X AND A VALUES SINCE WE LOOK FOR X=A AS
  9987. C A SEARCH CONDITION. WE MUST ASSUME THAT SOME SORT OF
  9988. C VARIATION OF ACCUMULATORS GIVEN WILL ALLOW US TO SATISFY
  9989. C THE EQUATION (X-A)=0.
  9990.     OLDX=AC(LX)
  9991.     IF(ID2A.NE.1)CALL XVBLGT(LX,ID2A,OLDX)
  9992. C    IF(ID2A.NE.1)OLDX=XVBLS(LX,ID2A)
  9993.     OLDA=AC(LA)
  9994.     IF(ID2B.NE.1)CALL XVBLGT(LA,ID2B,OLDA)
  9995. C    IF(ID2B.NE.1)OLDA=XVBLS(LA,ID2B)
  9996.     RETURN
  9997. 9900    CONTINUE
  9998.     RETCD=3
  9999.     RETURN
  10000. C PROC TO LOAD XVAC WITH VBLS(LLL)
  10001. 500    CONTINUE
  10002.     DO 501 KKKKN=1,8
  10003. 501    LAC(KKKKN)=AVBLS(KKKKN,LLL)
  10004.     GOTO LGET,(111,114,118,400,121,201,202,203,1101)
  10005. C PROC TO STORE XVAC INTO VBLS(LLL)
  10006. 600    CONTINUE
  10007.     DO 601 KKKKN=1,8
  10008. 601    AVBLS(KKKKN,LLL)=LAC(KKKKN)
  10009.     GOTO LPUT,(120,412,205)
  10010.     END
  10011. c -h- xqtcmd.for    Fri Aug 22 13:45:23 1986    
  10012. C $DO66
  10013.     SUBROUTINE XQTCMD(ICODE)
  10014. C COPYRIGHT (C) 1983-1990 GLENN AND MARY EVERHART
  10015. c All Rights Reserved
  10016.     Include AParms.inc
  10017. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  10018. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  10019. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  10020. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  10021. C FROM THE DISK BASED FILE HERE.
  10022.     CHARACTER*1 FORM,FVLD,CMDLIN(132),CL127(127)
  10023. C ALLOCATE EXTRA SLOP SPACE AFTER CMDLIN
  10024.     CHARACTER*1 CLWW(136)
  10025.     EQUIVALENCE(CLWW(1),CMDLIN(1))
  10026.     CHARACTER*127 CMDLNA
  10027.     EQUIVALENCE(CMDLIN(1),CL127(1),CMDLNA(1:1))
  10028. C    EQUIVALENCE(CMDLNA,CMDLIN(1))
  10029.     CHARACTER*127 WRKCHR,FORMCH,fwt
  10030. C    equivalence(fwt(1:1),formch(1:1))
  10031.     CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
  10032.     CHARACTER*1 WRKCHA(132),WRK127(127)
  10033.     EQUIVALENCE(WRKCHA(1),WRKCHR(1:1),WRK127(1),FORM2(1))
  10034. C    EQUIVALENCE(FORM2(1),WRK127(1))
  10035. C ***<<<< RDD COMMON START >>>***
  10036.     InTeGer*4 RRWACT,RCLACT
  10037. C    COMMON/RCLACT/RRWACT,RCLACT
  10038.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  10039.      1  IDOL7,IDOL8
  10040. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  10041. C     1  IDOL7,IDOL8
  10042.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  10043. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  10044.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  10045. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  10046. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  10047. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  10048. c    InTeGer*4 KLVL
  10049. C    COMMON/KLVL/KLVL
  10050.     InTeGer*4 KLVL,k3dfg,kcdelt,krdelt,kpag
  10051.     InTeGer*4 IOLVL,IGOLD
  10052. C    COMMON/IOLVL/IOLVL
  10053. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  10054. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  10055.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  10056.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  10057.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  10058.      3  k3dfg,kcdelt,krdelt,kpag
  10059. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  10060. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  10061. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  10062. c     3  k3dfg,kcdelt,krdelt,kpag
  10063. C ***<<< RDD COMMON END >>>***
  10064. CCC    InTeGer*4 RRWACT,RCLACT
  10065. CCC    COMMON/RCLACT/RRWACT,RCLACT
  10066.     INTEGER*4 VNLT
  10067.     EXTERNAL INDX
  10068. c    EQUIVALENCE(FORM2(1),WRKCHR)
  10069.     COMMON/NMSH/NMSH
  10070.     REAL*8 XVBLS(1,1)
  10071.     INTEGER KPYBAK
  10072. CCC    Integer*4 FH
  10073. CCC    Common/CONSFH/FH
  10074. C ***<<< KLSTO COMMON START >>>***
  10075.     InTeGer*4 DLFG
  10076. C    COMMON/DLFG/DLFG
  10077.     InTeGer*4 KDRW,KDCL
  10078. C    COMMON/DOT/KDRW,KDCL
  10079.     InTeGer*4 DTRENA
  10080. C    COMMON/DTRCMN/DTRENA
  10081.     REAL*8 EP,PV,FV
  10082.     DIMENSION EP(20)
  10083.     INTEGER*4 KIRR
  10084. C    COMMON/ERNPER/EP,PV,FV,KIRR
  10085.     InTeGer*4 LASTOP
  10086. C    COMMON/ERROR/LASTOP
  10087.     CHARACTER*1 FMTDAT(9,76)
  10088. C    COMMON/FMTBFR/FMTDAT
  10089.     CHARACTER*1 EDNAM(16)
  10090. C    COMMON/EDNAM/EDNAM
  10091.     InTeGer*4 MFID(2),MFMOD(2)
  10092. C    COMMON/FRM/MFID,MFMOD
  10093.     InTeGer*4 JMVFG,JMVOLD
  10094. C    COMMON/FUBAR/JMVFG,JMVOLD
  10095.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  10096.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  10097. C ***<<< KLSTO COMMON END >>>***
  10098. CCC    InTeGer*4 JMVFG,JMVOLD
  10099.     INTEGER*4 JVBLS(2,1,1)
  10100. CCC    COMMON/IOLVL/IOLVL
  10101. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  10102. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  10103. C PUT JMVFG INTO A PSECT BY ITSELF SO IT WILL SURVIVE OVERLAYS.
  10104. CCC    COMMON/FUBAR/JMVFG,JMVOLD
  10105.     DIMENSION FORM(128),FVLD(1,1)
  10106.     CHARACTER*1 DFE,FVWRK,FVWRK2,FRM127(127)
  10107.     EQUIVALENCE(FORM(1),FORMCH(1:1),FRM127(1))
  10108. C    EQUIVALENCE(FORM(1),FRM127(1)),(FRM127(1),FORMCH)
  10109.     DIMENSION DFE(14)
  10110.     CHARACTER*14 CDFE
  10111.     EQUIVALENCE(CDFE(1:1),DFE(1))
  10112. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  10113. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  10114. C SO INITIALLY IGNORE.
  10115. C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
  10116. C
  10117. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  10118. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  10119. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,
  10120. CCC     1  IDOL7,IDOL8
  10121.  
  10122. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,
  10123. CCC     1  IDOL7,IDOL8
  10124. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  10125. CCC    InTeGer*4 LLCMD,LLDSP
  10126. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  10127.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  10128.     COMMON/D2R/NRDSP,NCDSP
  10129.     InTeGer*4 ILNFG,ILNCT,RCF
  10130. C ***<<< NULETC COMMON START >>>***
  10131.     InTeGer*4 ICREF,IRREF
  10132. C    COMMON/MIRROR/ICREF,IRREF
  10133.     InTeGer*4 MODPUB,LIMODE
  10134. C    COMMON/MODPUB/MODPUB,LIMODE
  10135.     InTeGer*4 KLKC,KLKR
  10136.     REAL*8 AACP,AACQ
  10137. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  10138.     InTeGer*4 NCEL,NXINI
  10139. C    COMMON/NCEL/NCEL,NXINI
  10140.     CHARACTER*1 NAMARY(20,301)
  10141. C    COMMON/NMNMNM/NAMARY
  10142.     InTeGer*4 NULAST,LFVD
  10143. C    COMMON/NULXXX/NULAST,LFVD
  10144.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  10145.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  10146. C ***<<< NULETC COMMON END >>>***
  10147. CCC    COMMON/NCEL/NCEL,NXINI
  10148.     CHARACTER*1 ILINE(106)
  10149.     COMMON/ILN/ILNFG,ILNCT,ILINE
  10150. C ***<<< XVXTCD COMMON START >>>***
  10151.     CHARACTER*1 OARRY(100)
  10152.     InTeGer*4 OSWIT,OCNTR
  10153. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  10154. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  10155. C    InTeGer*4 IPS1,IPS2,MODFLG
  10156.     InTeGer*4 IC1POS,IC2POS,MODFLG
  10157. CCC    COMMON/ICPOS/IC1POS,IC2POS,MODFLG
  10158. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  10159.        InTeGer*4 XTCFG,IPSET,XTNCNT
  10160.        CHARACTER*1 XTNCMD(80)
  10161. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  10162. C VARY FLAG ITERATION COUNT
  10163.     INTEGER KALKIT
  10164. C    COMMON/VARYIT/KALKIT
  10165.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  10166.     InTeGer*4 RCMODE,IRCE1,IRCE2
  10167. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  10168. C     1  IRCE2
  10169. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  10170. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  10171. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  10172. C RCFGX ON.
  10173. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  10174. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  10175. C  AND VM INHIBITS. (SETS TO 1).
  10176.     INTEGER*4 FH
  10177. C FILE HANDLE FOR CONSOLE I/O (RAW)
  10178. C    COMMON/CONSFH/FH
  10179.     CHARACTER*1 ARGSTR(52,4)
  10180. C    COMMON/ARGSTR/ARGSTR
  10181.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  10182.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  10183.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  10184.      3  IRCE2,FH,ARGSTR
  10185. C ***<<< XVXTCD COMMON END >>>***
  10186. CCC    InTeGer*4 IC1POS,IC2POS,MODFLG
  10187. CCC    COMMON/ICPOS/IC1POS,IC2POS,MODFLG
  10188. CCC    CHARACTER*1 OARRY(100)
  10189. CCC    InTeGer*4 OSWIT,OCNTR
  10190. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  10191. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  10192.     InTeGer*4 TYPE(1,1),VLEN(9)
  10193.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  10194.     CHARACTER*1 FVLDTP
  10195.     REAL*8 XAC,ZAC
  10196.     EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
  10197.     REAL*8 XXAC,XYAC
  10198.     EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
  10199. CCC    InTeGer*4 NULAST,LFVD
  10200. CCC    COMMON/NULXXX/NULAST,LFVD
  10201. CCC    CHARACTER*1 ARGSTR(52,4)
  10202. CCC    COMMON/ARGSTR/ARGSTR
  10203. C    EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
  10204. C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
  10205. C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
  10206. C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
  10207. C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
  10208. C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
  10209.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  10210.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  10211.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  10212. CCC    COMMON/KLVL/KLVL
  10213.     CHARACTER*1 DEFVB(12)
  10214. CCC    InTeGer*4 MODPUB,LIMODE
  10215. CCC    COMMON/MODPUB/MODPUB,LIMODE
  10216.     COMMON/DEFVBX/DEFVB
  10217. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  10218. CCC     1  IRCE1,IRCE2
  10219. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  10220. CCC     1  IRCE1,IRCE2
  10221. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  10222. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  10223. C  AND VM INHIBITS. (SETS TO 1).
  10224. C
  10225. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  10226. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  10227. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  10228. C DISPLAY ACTUALLY USED FOR SCREEN.
  10229.     InTeGer*4 CWIDS(20)
  10230. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  10231. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  10232. C AS 20 NOT 75.
  10233.     REAL*8 DVS(20,75)
  10234.     INTEGER*4 LDVS(2,20,75)
  10235.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  10236.     COMMON /FVLDC/FVLD
  10237. C    CHARACTER*1 DFMTS(10,20,75)
  10238. C 10 CHARACTERS PER ENTRY.
  10239.     COMMON/DSPCMN/DVS,CWIDS
  10240. C THISRW,THISCL = CURRENT DISPLAYED LOCS.
  10241.     InTeGer*4 THISRW,THISCL
  10242. C    CHARACTER*1 IBITMP(2258)
  10243. C    COMMON/INITD/IBITMP
  10244. C FOLLOWING COMMON IS TO CONTROL "EXTERNAL" CALL OF XQTCMD
  10245. C TO ALLOW USE FROM INSIDE CELLS.
  10246. CCC    CHARACTER*1 XTNCMD(80)
  10247. CCC    InTeGer*4 XTCFG,XTNCNT,IPSET
  10248. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  10249.     CHARACTER*1 blanks
  10250.     dimension blanks(30)
  10251.     data blanks/30*' '/
  10252. C
  10253.     OSWIT=2
  10254. C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
  10255. C
  10256. C  COMMANDS INCLUDE:
  10257. C E = ENTER NUMBERS OR FORMULAS
  10258. C M = MOVE DIRECTION (1,2,3,4 = U,D,L,R)
  10259. C D = DISPLAY CHARACTERISTIC CHANGES
  10260. C
  10261. C DISPLAY ALTERING SUBCOMMANDS:
  10262. C  DL V1:V2 RN:M OR CN:M - DISPLAY VARIABLE RANGE V1:V2 AT DISPLAY
  10263. C  ROW OR COL N THRU M.
  10264. C  RN:M MEANS ACROSS A ROW ON DISPLAY STARTING AT DISPLAY COORD N,M
  10265. C  CN:M MEANS DOWN A DISPLAY COLUMN STARTING AT DISPLAY COORD N,M
  10266. C  DF V1:V2 FORMAT
  10267. C  SET FORMAT FOR DISPLAY OF V1 THRU V2 TO FORMAT (NOT INCL. )
  10268. C  A OR L DESIGNATOR SAYS SHOW TEXT IN FORMULA BUFFER. ELSE SHOW
  10269. C  NUMBER VALUE AT THAT LOC.
  10270. C  DT V1:V2 F OR I - SET NUMERIC TYPE OF V1 THRU V2 TO FLOAT OR INT.
  10271. C  DW N,M - SET WIDTH OF COL. N TO M CHARS WIDE.
  10272. C  DB MC,MR - SET MAX COLS TO MC, MAX ROWS TO MR.
  10273. C
  10274. C V = VIEWSCREEN UPDATE. REDISPLAY EVERYTHING FROM SCRATCH.
  10275. C VF = VIEW BUT DISPLAY FORMULAS ALL LOCS.
  10276. C VM = DISABLE REDRAWING SCREEN UNTIL A V IS SEEN.
  10277. C C = COPY NUMBERS/FORMULAS/DISPLAY STUFF(FORMAT)/ALL/RELOCATING
  10278. C 1,2,3,4 = MOVE CURSOR UP,DOWN,LEFT,RIGHT 1 ROW/COL
  10279. C (THESE DO NOT INVALIDATE CALCULATION SO RECALCULATION IS NOT
  10280. C DONE FOR THESE COMMANDS.)
  10281. C F FILENAME/NNN  FILL SCREEN (DISPLAYED PART ONLY) FROM FILENAME,
  10282. C    SKIPPING NNN RECORDS FIRST IF CALLED FOR. /NNN PART OPTIONAL.
  10283. C  (SPLITS STUFF READ IN ACROSS COLUMNS CURRENTLY DEFINED AND
  10284. C   SETS FVLD FOR DISPLAY OF TEXT, NOT #S.)
  10285. C AR/A n R/C ADDS/SUBTRACTS (INSERTS/DELETES) n ROWS OR COLUMNS
  10286. C   AT CURENT LOCATION. AR/AA SELECTS RELOCATING/ABSOLUTE.
  10287. C R = RECALCULATE SHEET. 17 = RECALCULATE MANUALLY ONLY (R RESETS)
  10288. C K = DROP INTO CALC CALCULATOR (*E RETURNS TO SHEET)
  10289. C L = LOCATE CURSOR (MOVE TO POSITION ON SHEET)
  10290. C (L VARIABLE IS THE COMMAND, AND IT LOCATES ORIGIN ON PHYSICAL
  10291. C SHEET. WILL ALSO MOVE CURSOR ON DISPLAY SHEET IF THAT CELL IS
  10292. C DISPLAYED, BUT OTHERWISE DOES NOT DISPLAY THE NUMBER.)
  10293. C Z = ZERO FORMULA/NUMBERS (OR ALL SHEET)
  10294. C  ZERO VARIABLE ZEROES THAT VARIABLE
  10295. C  ZERO VARIABLE1:VARIABLE2 ZEROES THAT RANGE (ROW OR COL)
  10296. C  ZERO * ZEROES ALL OF THE SHEET.
  10297. C X = EXIT (RETURNS TO OS)
  10298. C P = PUT NUMBERS TO FILE. ALWAYS GENERATES P#+nn#+mm forms based on
  10299. C current location.
  10300. C G = GET NUMBERS OUT OF FILE. USES CURRENT ORIGIN FROM L COMMAND OR 1,1
  10301. C TO ENTER NUMBERS (ALLOWS COMBINING DATA).
  10302. C W = WRITE SCREEN ON PRINTER (HARDCOPY FORMAT APPROX. AS DISPLAY.)
  10303. C OA VARIABLE = SET ORIGIN OF DISPLAY SHEET TO VARIABLE LOC IN
  10304. C  PHYSICAL SHEET (CLAMPED TO MAX. SIZE OF SHEET). STARTS AT R1,C1 OF
  10305. C  DISPLAY SHEET.
  10306. C OR VARIABLE = SET ORIGIN OF DISPLAY SHEET TO LOC'N OF VARIABLE IN
  10307. C  PHYSICAL SHEET. MODIFIES DISPLAY SHEET STARTING AT CURRENT DISPLAY
  10308. C  LOCATION RATHER THAN AT 1,1.
  10309. C
  10310. C NOTE THAT N-ARY FUNCTIONS ARE FNAMEARGS,ARGS,...
  10311. C AND RANGES ARE CELL1:CELLN. MULTIPLE COMMANDS IN FORMULA ARE
  10312. C DELIMITED BY \ CHARACTER.
  10313. C
  10314. C RETURN CODES:
  10315. C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
  10316. C THE ENTIRE SHEET.
  10317. C ICODE =-1 ==> REINITIALIZE DISPLAY DEFAULTS
  10318. C ICODE =2  ==> REDRAW WHOLE SCREEN
  10319. C ICODE =-2 ==> NEW SPREAD SHEET FILE SETUP.
  10320. C OTHER: ALL OK.
  10321. 498    CONTINUE
  10322.     KLVL=1
  10323.     ICODE=3
  10324. C DEFAULT RETURN CODE SAYING ALL WELL
  10325. C FIRST DISPLAY CURRENT CELL AGAIN IN NORMAL.
  10326.     THISRW=DROW
  10327.     THISCL=DCOL
  10328.     FORM(1)=0
  10329. C GET IN THE CURRENT FORMAT WHEREVER WE ARE, EVEN IF NOT ON DISPLAY SHEET.
  10330. C    IRRX=(PCOL-1)*60+PROW
  10331.     CALL REFLEC(PCOL,PROW,IRRX)
  10332.     CALL WRKFIL(IRRX,FORM2,0)
  10333.     CALL CE2A(FORM2,FORM)
  10334. C    READ(7'IRRX)FORM
  10335.     IF(THISRW.LE.0.OR.THISCL.LE.0)GOTO 200
  10336.     N1=NRDSP(THISRW,THISCL)
  10337.     N2=NCDSP(THISRW,THISCL)
  10338.     IXLSTC=THISCL
  10339.     IXLSTR=THISRW
  10340.     IF(THISCL.GT.DCLV.OR.THISRW.GT.DRWV)GOTO 200
  10341. C REDRAW LAST DISPLAYED CELL IN NORMAL (I.E., NOT REVERSE) VIDEO.
  10342. C    IF(ICHAR(FVLD(N1,N2)).EQ.0)GOTO 200
  10343. C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED.
  10344.     J=8
  10345. C    IRRX=(N2-1)*60+N1
  10346.     CALL REFLEC(N2,N1,IRRX)
  10347. C ADD 6 COLS FOR LABELS
  10348.     DO 1 M1=1,DROW
  10349. C FIND DISPLAY COLUMN TO USE
  10350. 1    J=J+CWIDS(M1)
  10351.     J=J-CWIDS(DROW)
  10352. C USE THISCL+1 TO LET 1ST ROW BE LABELS.
  10353.     ICCC=THISCL+2
  10354. C 0 = 1 IF VT100, 0 IF VT52
  10355. C SAVE PHYS COORDS BEING DISPLAYED NEXT. FVLD CAN BE TESTED FOR NUMERICS
  10356. C DIRECTLY, IF UVT100 NEEDS THAT ACCESS.
  10357.     IC1POS=N1
  10358.     IC2POS=N2
  10359.     IF(PZAP.NE.0)GOTO 3607
  10360.     CALL UVT100(1,ICCC,J)
  10361. C SELECT ROW "THISCL", COL "J"
  10362.     CALL UVT100(13,7,0)
  10363.     CALL FVLDGT(N1,N2,FVLD(1,1))
  10364. C    IF(FVLD(1,1).EQ.0)WRITE(6,5538)
  10365. C5538    FORMAT('>-<')
  10366.     ivv=min0(30,cwids(DROW))
  10367. c reset blanks to be sure we write something even for vt52
  10368. ccc    blanks(1)='>'
  10369.     IF(ICHAR(FVLD(1,1)).EQ.0)CALL SWRT(BLANKS,IVV)
  10370. ccc    blanks(1)=32
  10371. cccccc no VT52's in PCs...
  10372. C5538    FORMAT(1H+,30(a1,'\'))
  10373. 3607    CONTINUE
  10374. C WE CAN BE SURE THE COLUMN IS 3 WIDE OR MORE...
  10375.     CALL FVLDGT(N1,N2,FVLDTP)
  10376.     IF(ICHAR(FVLDTP).EQ.0)GOTO 200
  10377. C    IRRX=(N2-1)*60+N1
  10378. C SELECT REVERSE VIDEO
  10379.     DO 5540 KKKK=1,100
  10380. 5540    CMDLIN(KKKK)=char(32)
  10381.     CALL WRKFIL(IRRX,FORM2,0)
  10382.     CALL CE2A(FORM2,FORM)
  10383. C    READ(7'IRRX)FORM
  10384. C    IF(JCHAR(FORM(120)).LE.0)GOTO 200
  10385.     IF(JCHAR(FVLDTP).LT.0.OR.FORMFG.NE.0)
  10386.      1  WRITE(CMDLNA(1:127),8201)(FORM(II),II=1,100)
  10387. 8201    FORMAT(128A1)
  10388.     IF(FORMFG.NE.0)GOTO 4320
  10389.     DO 6301 KKK=1,9
  10390.     KKKK=ICHAR(FORM(KKK+119))
  10391. C    KKKK=DFMTS(KKK,THISRW,THISCL)
  10392. 6301    DFE(KKK+1)=CHAR(MAX0(32,KKKK))
  10393.     DFE(11)=CHAR(32)
  10394. C 32 = ASCII SPACE
  10395.     DFE(1)='('
  10396.     DFE(12)=' '
  10397.     DFE(13)=' '
  10398.     DFE(14)=')'
  10399.     CALL TYPGET(N1,N2,TYPE(1,1))
  10400.     IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
  10401.      1  WRITE(CMDLNA(1:127),DFE,ERR=4320)DVS(THISRW,THISCL)
  10402.     IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
  10403.      1   WRITE(CMDLNA(1:127),DFE,ERR=4320)LDVS(1,THISRW,THISCL)
  10404. C REDRAW THIS COL. WITH REVERSE VIDEO HERE.
  10405. 4320    IF(PZAP.EQ.0)CALL SWRT(CMDLIN,CWIDS(THISRW))
  10406. C9800    FORMAT('+',128(A,'\'))
  10407. 9000    FORMAT(128A1)
  10408.     IF(PZAP.EQ.0)CALL UVT100(13,0,0)
  10409. C NOTE THIS REDRAWS PREVIOUS COL. IN REVERSE VIDEO.
  10410. C NO CARRIAGE CTL
  10411. 200    CONTINUE
  10412.     IF(PZAP.NE.0)GOTO 3608
  10413.     KKKK=JCHAR(FVLDTP)
  10414. C SKIP LAST LINE UPDATE IF NOT NEEDED FOR SPEEDIER CURSOR
  10415. C POSITIONING.
  10416.     IF(NULAST.EQ.NCEL.AND.LFVD.EQ.0.AND.KKKK.EQ.0)GOTO 222
  10417.     CALL UVT100(1,LLDSP,1)
  10418.     CALL UVT100(12,2,0)
  10419.     IF(JCHAR(FORM(1)).LE.0)GOTO 222
  10420.     DO 1711 IVVVV=1,109
  10421.         IVV=110-IVVVV
  10422.     IF(JCHAR(FORM(IVV)).GT.32)GOTO 2711
  10423. 1711    CONTINUE
  10424. 2711    CONTINUE
  10425.     write(fwt(1:127),9092)ncel,(form(ii),ii=1,IVV)
  10426. 9092    FORMAT(1X,I5,' Used. Curr=',109A1)
  10427.     IVV=IVV+18
  10428.     call swrt(fwt(1:127),IVV)
  10429. C3608    CONTINUE
  10430. 222    CALL UVT100(1,LLCMD,1)
  10431.     NULAST=NCEL
  10432.     LFVD=KKKK
  10433.     CALL UVT100(12,2,0)
  10434. C NOTE PROW IS ACROSS TOP, PCOL IS DOWN SIDE
  10435. C PROW GOES AS ID1, ALPHAS
  10436. C PCOL GOES AS ID2, NUMERICS
  10437.     CALL IN2AS(PROW,FORM)
  10438. C NOTE PCOL STARTS AT 2 FOR NORMAL SHEET VARIABLES. PCOL=1 IS FOR ACCUMULATORS
  10439.     CALL UVT100(13,0,0)
  10440. C WRITE OUT LABEL WITH APPROPRIATE SIZE TO HOLD ROW NUMBER
  10441. C LET PROMPT END WITH > OR : DEPENDING ON OPERATING MODE.
  10442.     FVLDTP='>'
  10443.     IF(MODPUB.EQ.1)FVLDTP=':'
  10444.     IF(PCOL.GE.10000)GOTO 6401
  10445.     ii=pcol-1
  10446.     write(fwt(1:127),9001,err=3608)
  10447.      1   (form(i),i=1,4),ii,FVLDTP
  10448. C    FORM(9)=FVLDTP
  10449.     III=9
  10450.     GOTO 6402
  10451. 6401    CONTINUE
  10452.     ii=pcol-1
  10453.     write(fwt(1:127),9401,err=3608)
  10454.      1   (form(i),i=1,4),ii,FVLDTP
  10455. C    FORM(10)=FVLDTP
  10456.     III=10
  10457. 6402    CONTINUE
  10458.     CALL SWRT(fwt(1:127),III)
  10459. 9401    FORMAT(4A1,I5,1A1)
  10460. 9001    FORMAT(4A1,I4,1A1)
  10461. 3608    CONTINUE
  10462.     IF(XTCFG.NE.0)GOTO 3870
  10463.     Rewind 11
  10464.     IF(IOLVL.NE.11.or.FH.eq.0)READ(IOLVL,9002,END=510,ERR=510)CMDLIN
  10465. C FOR READING THE CONSOLE, WE NEED A QIO$ TO CAPTURE ESCAPE SEQUENCES.
  10466.     IF(IOLVL.EQ.11.and.FH.ne.0)CALL GETTTL(CMDLIN)
  10467.     CALL GTMUNG(CMDLIN)
  10468. C ALLOW CMD LANGUAGE TO LOOK MORE "STANDARD" VIA MUNGE OF INPUTS
  10469. C TO DO THE "EV" OR "ET" OR "EN" FOR USER AND TREAT / AS CMD
  10470. C PREFIX...
  10471.     GOTO 3871
  10472. 3870    CONTINUE
  10473.     XTCFG=0
  10474.     DO 3872 I=1,XTNCNT
  10475.     CMDLIN(I)=XTNCMD(I)
  10476. 3872    CONTINUE
  10477. C COPY IN EXTERNAL COMMAND AND LET IT BE EXECUTED. IT'S THE USER'S
  10478. C PROBLEM IF THE COMMAND REQUIRES STILL FURTHER INPUT...
  10479. C ALSO NULL OUT SOME DELIMITER CHARS AFTER THE COMMAND READ IN.
  10480.     CMDLIN(XTNCNT+1)=Char(0)
  10481.     CMDLIN(XTNCNT+2)=Char(0)
  10482. 3871    CONTINUE
  10483. 9002    FORMAT(64A1,64A1,32A1)
  10484.     CMDLIN(132)=Char(0)
  10485.     CMDLIN(131)=Char(0)
  10486.     CMDLIN(130)=Char(0)
  10487. C  SAVE CURRENT PHYS ROW, COL IN AC'S X AND Y
  10488.     XXAC=PROW
  10489.     XYAC=PCOL
  10490. C ZAP IN SPECIAL FUNCTION KEY REPLIES INTO NORMAL FORMS
  10491.     CALL CMDMUN(CMDLIN)
  10492.     DO 9048 I=1,129
  10493.     K=130-I
  10494. C START AT BACK OF LINE AND ZAP WHITESPACE BY NULL TERMINATOR
  10495.     IF(ICHAR(CMDLIN(K)).GT.32)GOTO 9049
  10496.     CMDLIN(K)=Char(0)
  10497. C ALSO GET RID OF POSSIBLE TRAILING CR, LF.
  10498. 9048    CONTINUE
  10499. 9049    CONTINUE
  10500. C
  10501. C THIS GETS COMMAND LINE IN. NOW ACTON IT.
  10502. C REPOS'N TO OLD LINE NOW.
  10503.     CALL UVT100(1,LLCMD,1)
  10504. C
  10505. C THE FOLLOWING SECTION IMPLEMENTS THE ADDITIONAL FUNCTION OF
  10506. C JOURNALING: (DONE ON VAX ONLY SINCE SPACE REQUIREMENTS FOR FILE
  10507. C OPERATIONS MAY BE A PROBLEM ON PDP11'S).
  10508. C    Command +J FILENAME will record all remaining
  10509. C    line inputs at this point in it. (Assumes JNLFLG=0 initially)
  10510. C    Command +N closes journal file.
  10511.     K=K+1
  10512.     IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'J'.AND.JNLFLG.NE.1)
  10513.      1   GOTO 4290
  10514.     IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'N')GOTO 4292
  10515.     IF(JNLFLG.EQ.1)WRITE(10,9002)(CMDLIN(IV),IV=1,K)
  10516.     GOTO 4291
  10517. 4292    CONTINUE
  10518.     CLOSE(10)
  10519.     JNLFLG=0
  10520.     GOTO 9990
  10521. 4290    CONTINUE
  10522.     JNLFLG=1
  10523. C    USE WHATEVER FILE NAME THE USER HAS SUPPLIED AFTER THE +J
  10524. C    FOR FILE TO JOURNAL ONTO. (NO MORE QUESTIONS NEEDED.)
  10525.     CALL WASSIG(10,CMDLIN(4))
  10526.     GOTO 9990
  10527. 4291    CONTINUE
  10528. C
  10529. C
  10530. C ALLOW COMMENTS IF LINE BEGINS WITH * (JUST LIKE CALC)
  10531.     IF(CMDLIN(1).NE.'*')GOTO 6002
  10532.     ICODE=1
  10533. C NO RECALC JUST FOR COMMENTS...
  10534.     GOTO 9990
  10535. 6002    CONTINUE
  10536. C
  10537. C * NEW ****************
  10538. C ADD PLACE TO PUT IN USER COMMANDS. DEFAULT IS NONE EXIST, DO NOTHING
  10539.     IGOTIT=0
  10540.     CALL USRCMD(CMDLIN,ICODE,IGOTIT)
  10541. C WHEN WE GET A COMMAND, SET IGOTIT TO 1 AND WE THEN PROCESS COMMAND NORMALLY
  10542.     IF(IGOTIT.EQ.1)GOTO 9990
  10543. C * NEW ****************
  10544. C
  10545. C COMMAND -PROMPT  WILL READ FROM LUN 5 TO ARGSTR
  10546. C TERMINATING WITH SPACES.
  10547.     IF(CMDLIN(1).NE.'-')GOTO 350
  10548.     ICODE=5
  10549.     CALL UVT100(1,LLCMD,1)
  10550.     CALL UVT100(12,2,0)
  10551.     CALL VWRT(CMDLIN(2),49)
  10552. C    WRITE(0,9800)(CMDLIN(IV),IV=2,50)
  10553.     call vget(form2,128)
  10554. c    READ(11,9000,END=510,ERR=510)FORM2
  10555.     II=1
  10556.     KK=1
  10557.     DO 351 KKK=1,128
  10558. C LOAD UP OUR ARGUMENTS IN ARGSTR(N,1) TO ARGSTR(N,4)
  10559.     ARGSTR(KK,II)=FORM2(KKK)
  10560.     KK=KK+1
  10561.     ARGSTR(KK,II)=0
  10562.     IF(KK.LT.52)GOTO 352
  10563. 354    KK=1
  10564.     II=II+1
  10565.     IF(II.GT.4)GOTO 353
  10566. 352    CONTINUE
  10567.     IF(ICHAR(FORM2(KKK)).GT.32)GOTO 351
  10568. C ON SPACE, GO TO THE NEXT ARGUMENT. ALSO SPILL INTO
  10569. C THE NEXT ARGUMENT IF WE SEE NO SPACES AND JUST TRAIL ALONG.
  10570.     GOTO 354
  10571. 351    CONTINUE
  10572. 353    GOTO 9990
  10573. 350    CONTINUE
  10574. C
  10575. C CONTROL SCROLLING. PERMIT THE COMMAND "SC" TO TURN SCROLLING ON
  10576. C AND "NS" TO TURN IT BACK OFF.
  10577.     IVV=-1
  10578.     IF(CMDLIN(1).EQ.'S'.AND.CMDLIN(2).EQ.'C')IVV=1
  10579.     IF(CMDLIN(1).EQ.'N'.AND.CMDLIN(2).EQ.'S')IVV=0
  10580.     IF(IVV.GE.0)IDOL7=IVV
  10581.     IF(IVV.GE.0)ICODE=5
  10582.     IF(IVV.GE.0)GOTO 9990
  10583. C
  10584. C ALLOW PROGRAMMED "REWIND" OF INPUT COMMAND LINE ON
  10585. C COMMAND LINE BEGINNING WITH "<". MAKE IT CONDITIONAL
  10586. C BY SAYING THAT IF % IS NEGATIVE WE WON'T DO IT.
  10587.     IF(CMDLIN(1).NE.'<')GOTO 356
  10588.     ICODE=5
  10589.     IF(XAC.GT.0..AND.IOLVL.NE.11)REWIND IOLVL
  10590.     GOTO 9990
  10591. 356    CONTINUE
  10592. C
  10593. C HANDLE @FILE COMAND TO CHANGE TO INPUT OFF THAT FILE.
  10594.     IF(CMDLIN(1).NE.'@')GOTO 511
  10595. C WOW, A FILE. (OR AT LEAST SO WE HOPE).
  10596.     CALL RASSIG(3,CMDLIN(2))
  10597. C USE FACT THAT WE JUST NULL TERMINATED THE FILENAME PART AND SET
  10598. C IT TO BE LUN 3.
  10599.     IOLVL=3
  10600. C NOW GO BACK FOR ANOTHER COMMAND...NO SENSE WASTING RECALC TIME SINCE
  10601. C NOTHING HAS REALLY HAPPENED YET.
  10602. C NOTE EVERY READ TO LUN 3 HAS EOF/ERROR CHECK TO GO TO 510 TO RESET
  10603. C TO LUN 5 INPUT AND CLOSE FILE WE OPENED ON 3.
  10604.     GOTO 498
  10605. 511    CONTINUE
  10606. C
  10607. C AA n R, AA n C, AR n R, AR n C COMMANDS
  10608. C
  10609.     IF(CMDLIN(1).NE.'O'.OR.CMDLIN(2).NE.'V')GOTO 6887
  10610. C OV + TURNS ON OVERRIDE
  10611. C OV - TURNS OFF OVERRIDE
  10612. C ALLOWS ONE TO OVERRIDE $ SIGN FORMS' ABSOLUTE NATURE
  10613.     IF(CMDLIN(3).EQ.'+'.OR.CMDLIN(4).EQ.'+')IDOL3=1
  10614.     IF(CMDLIN(3).EQ.'-'.OR.CMDLIN(4).EQ.'-')IDOL3=0
  10615.     GOTO 9990
  10616. 6887    CONTINUE
  10617.     IF(CMDLIN(1).NE.'A')GOTO 8845
  10618. C ADD ROWS OR COLUMNS (OR REMOVE THEM) AT THE CURRENT PHYSICAL LOCATION
  10619. C WHERE AA MEANS ADD ABSOLUTE (NO RELOCATION), AR MEANS ADD RELOCATING
  10620. C (RELOCATE ALL VARIABLES BELOW), AND R OR C SAYS TO ADD/SEBTRACT ROWS
  10621. C OR COLUMNS.
  10622. C
  10623. C FIRST COLLECT THE ARGUMENTS TO THE FUNCTION.
  10624.     KM1=3
  10625.     KM2=10
  10626.     CALL GN(KM1,KM2,ICNT,CMDLIN)
  10627. C GETS THE NUMBER. IF NO NUMBER SEEN OR ZERO, RETURNS 0. IGNORE THEN.
  10628.     IF(ICNT.EQ.0)GOTO 9990
  10629.     ICR=0
  10630. C LOOK FOR THE R OR C
  10631. C START AT CMDLIN(4) TO PASS THE AR/AA AND THE NUMBER IF ANY.
  10632.     DO 8844 KKK=4,50
  10633.     IF(CMDLIN(KKK).EQ.'R')ICR=1
  10634.     IF(CMDLIN(KKK).EQ.'C')ICR=2
  10635.     IF(ICR.NE.0)GOTO 8846
  10636. C SKIP OUT ON FIRST ROW OR COLUMN DESIGNATOR SEEN
  10637. 8844    CONTINUE
  10638. 8846    CONTINUE
  10639.     IF(ICR.EQ.0)GOTO 9990
  10640.     ICODE=2
  10641. C NOW WE HAVE ALL ARGUMENTS. SET UP FOR THE COPY AND PARASITE THE
  10642. C LOGIC USED FOR THE CA OR CR COMMANDS. (NOTE THAT 2ND CHARACTER
  10643. C IS A OR R IN CMDLIN ALREADY SO THOSE COMMANDS' LOGIC WILL BE OK.)
  10644.     JRTR=PROW
  10645.     JRTC=PCOL
  10646.     IF(ICR.EQ.2)JRTC=1
  10647.     IF(ICR.EQ.1)JRTR=1
  10648. C RELOC THESHOLD IS PHYSICAL CURRENT POSITION.
  10649.     IF(ICR.EQ.1)GOTO 8843
  10650. C INSERT OR DELETE COLUMNS
  10651. C FIRST FIGURE OUT HOW MANY COLUMNS MUST BE MOVED RIGHT
  10652.     KD=MCols-PROW-IABS(ICNT)+1
  10653. C LET THIS WORK ONLY ON PRIME SHEET. TOO HARD TO FIGURE IT OUT ON REFLECTED
  10654. C ONES AND IT'LL FOUL LOTS OF USERS UP.
  10655.     IF(KD.LE.0)GOTO 9990
  10656. C CAN'T MOVE 0 COLUMNS. DOESN'T MAKE SENSE.
  10657.     DO 8842 KR=1,KD
  10658.     IRA=MCols-KR+1
  10659. C IRA IS DESTINATION COLUMN IN EACH LOOP.
  10660.     IF(ICNT.LT.0)IRA=PROW-1+KR
  10661. C IRS IS SOURCE COLUMN
  10662.     IRS=MCols-KR+1-ICNT
  10663.     IF(ICNT.LT.0)IRS=PROW+KR-ICNT-1
  10664. C
  10665. C IF DELETING COLUMNS AND DESTINATION IS PAST CURRENT
  10666. C ACTIVE MAX, SKIP THE MOVE SINCE WE'RE NOT ACCOMPLISHING ANYTHING.
  10667.     IF(ICNT.LT.0.AND.IRA.GT.RRWACT)GOTO 8842
  10668. C IF ADDING COLUMNS AND SOURCE IS PAST CURRENT MAX ACTIVE THEN
  10669. C WE'RE DOING NOTHING, SO SKIP THE WORK
  10670.     IF(ICNT.GT.0.AND.IRS.GT.RRWACT)GOTO 8842
  10671.     JDELT=RCLACT
  10672. C    JDELT=301
  10673. C LOOP WE'LL CALL IS OVER ENTIRE ROWS, BUT ONLY DO ONE AT A TIME HERE
  10674.     JD1A=IRA
  10675.     JD1B=1
  10676.     ID1A=IRS
  10677.     ID2A=1
  10678.     I1IN=0
  10679.     I2IN=1
  10680.     JIN1=0
  10681.     JIN2=1
  10682.     ASSIGN 8840 TO KPYBAK
  10683. C CALL INTERNAL COPY-RANGE PROCEDURE INSIDE CA/CR LOGIC
  10684.     GOTO 8364
  10685. 8840    CONTINUE
  10686. 8842    CONTINUE
  10687. C
  10688. C NOW CLEAN UP THE REST OF FORMULAS IF THERE ARE ANY TO DO...
  10689. C MUST RELOCATE OTHER FORMULAE IF CMDLIN(2) IS R
  10690.     KX=PROW-1
  10691. C RELY ON RCLACT HAVING BEEN UPDATED TO REFLECT NEW
  10692. C ADDITIONS IF ANY
  10693.     KY=RCLACT
  10694. C    KY=301
  10695. C RELOCATE UPPER LEFT PART OF SHEET
  10696. C NOTE II1,II2,JJ1,JJ2,JRTR,JRTC ARE UNCHANGED FROM PRIOR CALL SO
  10697. C MAY BE USED... RELVBL ONLY CARES ABOUT RELATIVE MOTION ANYHOW...
  10698. 3600    CONTINUE
  10699.     IF(CMDLIN(2).NE.'R'.OR.KX.LE.0.OR.KY.LE.0)GOTO 9990
  10700.     DO 3601 KK=1,KX
  10701.     DO 3601 KK2=1,KY
  10702.     CALL FVLDGT(KK,KK2,FVLD(1,1))
  10703.     IF(ICHAR(FVLD(1,1)).NE.1)GOTO 3601
  10704. C ONLY RELOCATE FORMULAS, NOT TEXT OR NUMBERS (OR EMPTIES...)
  10705. C    IRX=(KK2-1)*60+KK
  10706.     CALL REFLEC(KK2,KK,IRX)
  10707.     CALL WRKFIL(IRX,FORM,0)
  10708. C    READ(7'IRX)FORM
  10709.     CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC)
  10710.     CALL WRKFIL(IRX,FORM2,1)
  10711. C    WRITE(7'IRX)FORM2
  10712. 3601    CONTINUE
  10713.     GOTO 9990
  10714. 8843    CONTINUE
  10715. C ROW INSERT/DELETE
  10716. C AGAIN FIND HOW MANY ROWS TO MOVE.
  10717.     KD=MRows-PCOL-IABS(ICNT)+1
  10718.     IF(KD.LE.0)GOTO 9990
  10719.     DO 8839 KC=1,KD
  10720. C ICA = DESTINATION AND ICS IS SOURCE
  10721.     ICA=MRows-KC+1
  10722.     ICS=MRows-KC+1-ICNT
  10723.     IF(ICNT.GT.0)GOTO 8838
  10724.     ICA=PCOL-1+KC
  10725.     ICS=PCOL+KC-1-ICNT
  10726. 8838    CONTINUE
  10727. C IF INSERTING ROWS AND SRC ROW IS BEYOND ACTIVE AREA, SKIP
  10728.     IF(ICNT.GT.0.AND.ICS.GT.RCLACT)GOTO 8839
  10729. C IF DELETING ROWS AND DST ROW IS BEYOND ACTIVE AREA, SKIP
  10730.     IF(ICNT.LT.0.AND.ICA.GT.RCLACT)GOTO 8839
  10731. C NOW CALL COPY LOOP AGAIN.
  10732.     JDELT=RRWACT
  10733. C    JDELT=60
  10734.     JD1A=1
  10735.     JD1B=ICA
  10736. C DEST
  10737.     ID1A=1
  10738.     ID2A=ICS
  10739. C SOURCE
  10740.     I1IN=1
  10741.     I2IN=0
  10742.     JIN1=1
  10743.     JIN2=0
  10744.     ASSIGN 8836 TO KPYBAK
  10745. C CALL INTERNAL RANGE COPY PROCEDURE TO COPY A ROW
  10746.     GOTO 8364
  10747. 8836    CONTINUE
  10748. 8839    CONTINUE
  10749.     KX=RRWACT
  10750. C    KX=60
  10751.     KY=PCOL-1
  10752.     GOTO 3600
  10753. 8845    CONTINUE
  10754. C OA AND OR COMMANDS. SET DISPLAY SHEET MAPPING TO ORIGIN AS FOUND BY
  10755. C  VARIABLE, STARTING AT 1,1 OR (DROW,DCOL) FOR OA AND OR RESPECTIVELY.
  10756.     IF(CMDLIN(1).NE.'O')GOTO 650
  10757. C PROCESS COMMAND...
  10758.     LRO=1
  10759.     LCO=1
  10760.     IF(CMDLIN(2).EQ.'R')LRO=MAX0(1,DROW)
  10761.     IF(CMDLIN(2).EQ.'R')LCO=MAX0(1,DCOL)
  10762. C OM will act like OR in that it will set the mapping of a
  10763. C display starting at the cursor, but unlike OR it will
  10764. C map multiple pages. When 3D actions are disabled it will
  10765. C do nothing.
  10766.     KORM=0
  10767.     IF(CMDLIN(3).NE.'M')GOTO 3944
  10768.     IF(K3DFG.LE.0)GOTO 3924
  10769. C OAMC/ORMC cell remaps display so that each display column is
  10770. C a column from the next lower sheet, so that, for example,
  10771. C a first column might be a1:a20, the next might be a1%1:a20%1,
  10772. C the next a1%2:a20%2 and so on.
  10773. C
  10774. C OAMR/ORMR cell remaps display so that each display row is a row
  10775. C from the next lower sheet, so that for example the first
  10776. C row might be a1:g1, the next a1%1:g1%1, the next a1%2:g1%2
  10777. C and so on. 
  10778. C
  10779. C  Thus the operation ORMC fills the 1st column with the current
  10780. C sheet, then the next with the offsets of the first plus the
  10781. C sheet offset, and so on. ORMR fills the 1st row with the
  10782. C current sheet, then sheet offsets down.
  10783.     IF(CMDLIN(4).EQ.'C')KORM=1
  10784.     IF(CMDLIN(4).EQ.'R')KORM=2
  10785.     IF(KORM.EQ.0)GOTO 3924
  10786. 3944    CONTINUE
  10787. c *** 20 by 75 display constants hardcoded here:
  10788.     LRO=MIN0(LRO,19)
  10789.     LCO=MIN0(LCO,74)
  10790. C    LRO=MIN0(LRO,(20-1))
  10791. C    LCO=MIN0(LCO,(75-1))
  10792. C NOW HAVE CORRECT ORIGIN IN DISPLAY SHEET TO USE SET UP.
  10793. C GRAB VARIABLE ID.
  10794.     LA=INDX(CMDLIN,32)
  10795.     IF(LA.GT.20)LA=3
  10796.     LE=40
  10797.     CALL VARSCN(CMDLIN,LA,LE,LSTCX,ID1,ID2,IVLD)
  10798.     IF(IVLD.EQ.0)GOTO 651
  10799. C NOW HAVE VARIABLE NAME AND LOCATION... CAN DO IT FINALLY.
  10800. C NOTE WE'RE GUARANTEED WE START OFF IN BOUNDS BUT MUST CHECK
  10801. C ALONG THE WAY TO BE SURE WE STAY THAT WAY.
  10802.     IQQ=0
  10803.     KKKK=0
  10804. C allow a D modifier (for whatever it's worth) after
  10805. C the ORMR/ORMC/OAMR/OAMC commands. It will be as close to
  10806. C the normal OAD/ORD as practical under the circumstances of
  10807. C a totally different mapping scheme.
  10808.     IF(KORM.NE.0.and.CMDLIN(5).eq.'D')KKKK=1
  10809.     IF(CMDLIN(3).NE.'D')GOTO 6712
  10810. c allow ORA or ORD commands to leave window displacements
  10811. c alone. Fix up so this is default mode for scrolling (making
  10812. c program behavior easier to understand.)
  10813. 7112    CONTINUE
  10814.     KKKK=1
  10815. 6712    CONTINUE
  10816.     KKKKK=NRDSP(LRO,LCO)
  10817.     KKKKKK=NCDSP(LRO,LCO)
  10818. 5711    CONTINUE
  10819. C TO ALLOW REFLECTIONS MUST ALLOW ALL SORTS OF ORIGINS.
  10820.     DO 652 IRO=LRO,DRWV
  10821.     DO 653 ICO=LCO,DCLV
  10822. C HERE CAN SET UP NRDSP AND NCDSP SUITABLY
  10823.     IVV=IRO-LRO
  10824.     IVVV=ICO-LCO
  10825.     IF(KKKK.EQ.0)GOTO 1653
  10826.     IVV=NRDSP(IRO,ICO)-KKKKK
  10827.     IVVV=NCDSP(IRO,ICO)-KKKKKK
  10828. 1653    CONTINUE
  10829.     if(korm.ne.1)goto 2653
  10830. C OMC column mode remap.
  10831. C Bump offsets by kcdelt/krdelt as iro grows BUT
  10832. C not as ico grows.
  10833.     IVV=(LRO-1)+(iro-lro)*kcdelt
  10834.     IVVV=IVVV+(iro-lro)*krdelt
  10835. 2653    Continue
  10836.     if(korm.ne.2)goto 2654
  10837. C OMR row mode remap.
  10838. C bump offsets by kcdelt/krdelt as ico grows BUT not as
  10839. C iro grows.
  10840.     IVV=IVV+(ico-lco)*kcdelt
  10841.     IVVV=(LCO-1)+(ico-lco)*krdelt
  10842. 2654    Continue
  10843.     NRDSP(IRO,ICO)=ID1+IVV
  10844.     NCDSP(IRO,ICO)=ID2+IVVV
  10845. 653    CONTINUE
  10846. 652    CONTINUE
  10847.     IF(DROW.LE.0.OR.DCOL.LE.0)GOTO 3924
  10848.     PROW=NRDSP(DROW,DCOL)
  10849.     PCOL=NCDSP(DROW,DCOL)
  10850. 3924    CONTINUE
  10851. C FORCE REDRAW OF WHOLE SHEET.
  10852.     ICODE=6
  10853.     IF(RCMODE.LE.0)GOTO 9990
  10854. C SKIP RECALC IF IN OLD MODE...
  10855.     ICODE=2
  10856. 651    GOTO 9990
  10857. 650    CONTINUE
  10858. C F FILENAME/NNN
  10859. C READ IN TEXT FROM FILE NAMED AND SPREAD ACROSS DISPLAY SCREEN. SET
  10860. C DISPLAYED SCREEN INTO FVLD(NN)=-1 TO SHOW TEXT ONLY.
  10861.     IF(CMDLIN(1).NE.'F')GOTO 1740
  10862.     LA=INDX(CMDLIN,32)
  10863. C PASS SPACE
  10864.     KKK=ICHAR('/')
  10865.     LB=INDX(CMDLIN(LA+1),KKK)
  10866.     LB=LB+LA
  10867. C LB= LOC OF / CHARACTER
  10868.     LB=MIN0(80,LB)
  10869.     IF(LB.LE.2)GOTO 1741
  10870.     IF((LB-LA).LE.1) GOTO 1741
  10871.     CMDLIN(LB)=0
  10872.     CALL RASSIG(4,CMDLIN(LA+1))
  10873. C THIS OUGHT TO OPEN THE FILE IF IT EXISTS..
  10874. C NOW IF THERE'S A NUMBER THERE, EXTRACT IT.
  10875.     LSKP=0
  10876.     IF(LB.GT.78.OR.LB.LE.5)GOTO 1743
  10877.     LAA=LB+1
  10878.     LAAA=LB+7
  10879.     CALL GN(LAA,LAAA,LSKP,CMDLIN)
  10880. 1743    CONTINUE
  10881. C NOW SKIP THE LINES
  10882.     IF(LSKP.LE.0)GOTO 1744
  10883.     DO 1745 IV=1,LSKP
  10884.     READ(4,8201,END=1742,ERR=1742)FORM2
  10885. 1745    CONTINUE
  10886. 1744    CONTINUE
  10887. C NOW WE'RE READY TO READ IN THE STUFF.
  10888.     ICODE=2
  10889.     DO 1746 LA=1,DCLV
  10890.     DO 1751 IV=1,128
  10891. 1751    FORM2(IV)=Char(32)
  10892.     READ(4,8201,END=1742,ERR=1742)FORM2
  10893.     IXC=0
  10894.     DO 1747 LB=1,DRWV
  10895. C DRWV = # ACROSS TOP...
  10896. C DCLV=LENGTH
  10897.     ID1=NRDSP(LB,LA)
  10898.     ID2=NCDSP(LB,LA)
  10899. C GET PHYSICAL SHEET COORDINATES AS ID1,ID2
  10900. C MUST THEN COPY CWIDS(LB) CHARS ONTO FILE...
  10901.     CALL FVLDST(ID1,ID2,char(255))
  10902. C    FVLD(ID1,ID2)=-1
  10903. C    IRX=(ID2-1)*60+ID1
  10904.     CALL REFLEC(ID2,ID1,IRX)
  10905.  
  10906.     CALL WRKFIL(IRX,FORM,0)
  10907. C    READ(7'IRX)FORM
  10908.     FORM(119)=Char(255)
  10909.     DO 1749 IVV=1,110
  10910. 1749    FORM(IVV)=0
  10911.     DO 1748 IVV=1,CWIDS(LB)
  10912.     IXC=IXC+1
  10913. 1748    FORM(IVV)=FORM2(IXC)
  10914.     CALL WRKFIL(IRX,FORM,1)
  10915. 1747    CONTINUE
  10916. 1746    CONTINUE
  10917. 1742    CLOSE(4)
  10918. 1741    GOTO 9990
  10919. 1740    CONTINUE
  10920.     IF(CMDLIN(1).NE.'E')GOTO 8000
  10921. C ENTER COMMAND
  10922. C EN expression. expression may be numbers/text.
  10923.     LA=INDX(CMDLIN,32)
  10924.     LA=LA+1
  10925. C SKIP SPACE AFTER "EN"
  10926.     IF(LA.GT.4)LA=4
  10927.     IF (LA.GE.100)GOTO 7901
  10928.     LE=132-LA
  10929.     LE=MIN0(110,LE)
  10930. C    IRX=(PCOL-1)*60+PROW
  10931.     CALL REFLEC(PCOL,PROW,IRX)
  10932. C FIND WHERE IN FILE TO STORE.
  10933.     CALL WRKFIL(IRX,FORM2,0)
  10934.     CALL CE2A(FORM2,FORM)
  10935. C    READ(7'IRX)FORM
  10936.     IF(CMDLIN(2).EQ.'D')
  10937.      1   CALL SED(CMDLIN(LA),FORM,FORM2,ARGSTR,ZAC,110)
  10938. C IF COMMAND IS "ED <DELIM>STRING1<DELIM>STRING2<DELIM>" THEN
  10939. C  SUBSTITUTE STRING2 FOR STRING1 IN FORMULA, RETURN IT TO THE
  10940. C  COMMAND LINE, AND REENTER IT.
  10941. C  NOTE THAT THE STRINGS MAY CONTAIN &n FORMS WHERE 1-4 MEAN
  10942. C  ENTERED ARGUMENTS 1-4, 5 TREATS XAC AS A NUMBER, AND 6
  10943. C  TREATS ZAC AS A SINGLE CHARACTER (ZAC IS VARIABLE Z).
  10944.     DO 5133 II=1,110
  10945. 5133    FORM(II)=0
  10946.     NALF=0
  10947.     NSG=-1
  10948.     NXNUM=3
  10949.     KSG=0
  10950.     N=1
  10951.     IRCE1=PROW
  10952.     IRCE2=PCOL
  10953. C SAVE FOR RE, RI MODES
  10954.     IF(CMDLIN(2).EQ.'T'.OR.CMDLIN(2).EQ.'"')KSG=1
  10955. C "ET" FORMULA ENTERS TEXT ONLY
  10956. C "EV" FORMULA ENTERS NUMBER
  10957.     IF(CMDLIN(2).EQ.'V')NSG=1
  10958. 2097    CONTINUE
  10959.     IF(N.GT.LE)GOTO 7902
  10960. C    DO 7902 N=1,LE
  10961. C LOOK FOR ALPHAS. IF WE FIND ANY, FLAG NOT NUMERIC
  10962. C NOTE @ INCLUDED SINCE COULD HAVE A *@3 COMMAND TO CALL 3.CMD
  10963. C AND REFER TO OTHER CELLS.
  10964. C THIS IS A RESTRICTION: COMMANDS TO CMND NEED TO HAVE ALPHAS
  10965. C SOMEWHERE OR THIS WILL BE FOOLED.
  10966.     IF(CMDLIN(LA).EQ.'P'.AND.
  10967.      1  CMDLIN(LA+1).EQ.'#'.AND.
  10968.      2  CMDLIN(LA+2).EQ.'0'.AND.
  10969.      3  CMDLIN(LA+3).EQ.'#'.AND.
  10970.      4  CMDLIN(LA+4).EQ.'0') GOTO 3356
  10971.     IF(ICHAR(CMDLIN(LA)).GE.ICHAR('@').AND.ICHAR(CMDLIN(LA))
  10972.      1  .LE.ICHAR('Z'))NXNUM=1
  10973. 3356    CONTINUE
  10974.     IF(CMDLIN(LA).EQ.'+'.OR.CMDLIN(LA).EQ.'-')NSG=1
  10975.     IF(CMDLIN(LA).EQ.'['.OR.CMDLIN(LA).EQ.'.')NSG=1
  10976.     IF(CMDLIN(LA).EQ.'(')NSG=1
  10977.     IF(CMDLIN(LA).EQ.'"')KSG=1
  10978. C ON SEEING THE _@V1,V2 CONSTRUCT, REPLACE WITH THE VARIABLE
  10979. C ADDRESSED BY V1,V2 (COL,ROW) BY NAME.
  10980. C ON SEEING THE _#V1 CONSTRUCT, UNPACK UP TO 8 CHARS OUT OF
  10981. C REAL*8 VARIABLE (PACKED BY MULTIPLYING BY 128 EARLIER).
  10982. C  IN EACH CASE, ADJUSTN AND LE TO CONTINUE APPROPRIATELY.
  10983.     IF(ICHAR(CMDLIN(LA)).GT.32)NALF=NALF+1
  10984.     IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'@')CALL
  10985.      1  SVBL(CMDLIN,LA,N,LE,FORM)
  10986.     IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'#')CALL
  10987.      1  SSTR(CMDLIN,LA,N,LE,FORM)
  10988.     FORM(N)=CMDLIN(LA)
  10989.     LA=LA+1
  10990. C FAKE OUT DO LOOP SINCE SVBL OR SSTR MAY MUNG INDICES INSIDE IT
  10991.     N=N+1
  10992.     GOTO 2097
  10993. 7902    CONTINUE
  10994.     IF(KSG.NE.0)NSG=-1
  10995.     FORM(110)=0
  10996.     IF(ICHAR(FORM(119)).NE.0)GOTO 7903
  10997. C LEAVE DISPLAY INDICATOR ALONE IF SET BUT SET VBL OTHERWISE.
  10998.     IVVVV=NSG*NXNUM
  10999.     FORM(119)=CHAR(IVVVV)
  11000. C SET NEG FOR DISPLAY OF FORMULA, NOT NUMBER. ALLOWS TEXT ENTRY.
  11001. C ASSUME FORMULA IF WE SEE + OR -
  11002. 7903    CONTINUE
  11003. C FORCE FORM TO FOLLOW EDITS EVEN IF FORMAT/TYPE PRESET.
  11004.     IVVVV=JCHAR(FORM(119))
  11005.     IF(IVVVV.NE.0)FORM(119)=CHAR(ISGN(IVVVV)*NXNUM)
  11006.     IF(NALF.LE.0)GOTO 6221
  11007.     CALL FVLDST(PROW,PCOL,FORM(119))
  11008. C ENCODE CELL NAMES PRIOR TO STORING
  11009.     CALL CA2E(FORM,FORM2)
  11010.     CALL WRKFIL(IRX,FORM2,1)
  11011. 6221    CONTINUE
  11012.     ASSIGN 7904 TO NBK
  11013.     GOTO 7905
  11014. C LOOK UP PROW, PCOL, LEAVE DISPLAY COORDS IN LR,LC
  11015. 7905    CONTINUE
  11016.     DO 7906 LA1=1,DRWV
  11017.     LR=LA1
  11018.     DO 7906 LA2=1,DCLV
  11019.     LC=LA2
  11020.     IF(NRDSP(LA1,LA2).EQ.PROW.AND.NCDSP(LA1,LA2).EQ.PCOL)GOTO7907
  11021. 7906    CONTINUE
  11022. C IF WE FALL OUT OF THE LOOP, WE DIDN'T FIND THE LOC; FLAG BY PUTTING 0'S.
  11023.     LR=0
  11024.     LC=0
  11025.     GOTO 7908
  11026. 7907    CONTINUE
  11027. C ARRIVE HERE ON SUCCESS. LR, LC ALL SET UP.
  11028. 7908    CONTINUE
  11029.     GOTO NBK,(7904,8901,8957)
  11030. 7904    CONTINUE
  11031.     IF(LR.EQ.0.OR.LC.EQ.0)GOTO 7901
  11032.     THISRW=LR
  11033.     THISCL=LC
  11034. C    ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL.
  11035.     LRO=1
  11036.     LCO=1
  11037.     ID1=NRDSP(1,1)
  11038.     ID2=NCDSP(1,1)
  11039.     IF(.NOT.(JMVFG.EQ.51.AND.THISRW.EQ.1))GOTO 7110
  11040. C MUST SCROLL LEFT
  11041.     IF(IDOL7.EQ.0)GOTO 7110
  11042.     IF(ID1.LE.1)GOTO 7110
  11043.     ID1=MAX0(1,ID1-DRWV+2)
  11044.     DROW=MAX0(1,DRWV-2)
  11045.     IQQ=1
  11046.     GOTO 7112
  11047. 7110    CONTINUE
  11048.     IF(JMVFG.EQ.51)THISRW=MAX0(1,(THISRW-1))
  11049.     IF(.NOT.(JMVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 7116
  11050. C MUST SCROLL RIGHT
  11051.     IF(IDOL7.EQ.0)GOTO 7116
  11052.     DROW=3
  11053. C    ID1=MIN0(60,ID1+DRWV-MIN0(DRWV,2))
  11054.     ID1=ID1+DRWV-MIN0(DRWV,2)
  11055.     IQQ=1
  11056.     GOTO 7112
  11057. C 7112 FAKES OUT OA CALL TO SCROLL OVER.
  11058. 7116    CONTINUE
  11059.     IF(JMVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV)
  11060.     IF(.NOT.(JMVFG.EQ.49.AND.THISCL.EQ.1))GOTO 7117
  11061. C MUST SCROLL UP
  11062.     IF(IDOL7.EQ.0)GOTO 7117
  11063.     IF(ID2.LE.2)GOTO 7117
  11064.     DCOL=MAX0(1,DCLV-2)
  11065.     ID2=MAX0(2,ID2-DCLV+2)
  11066.     IQQ=1
  11067.     GOTO 7112
  11068. 7117    CONTINUE
  11069.     IF(JMVFG.EQ.49)THISCL=MAX0(1,(THISCL-1))
  11070.     IF(.NOT.(JMVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 7118
  11071. C MUST SCROLL DOWN
  11072.     IF(IDOL7.EQ.0)GOTO 7118
  11073.     DCOL=3
  11074. C    ID2=MIN0(301,ID2+DCLV-MIN0(DCLV,2))
  11075.     ID2=ID2+DCLV-MIN0(DCLV,2)
  11076.     IQQ=1
  11077.     GOTO 7112
  11078. 7118    CONTINUE
  11079.     IF(JMVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV)
  11080.     DROW=THISRW
  11081.     DCOL=THISCL
  11082.     PROW=NRDSP(DROW,DCOL)
  11083.     PCOL=NCDSP(DROW,DCOL)
  11084. C FORCE REDO OF BOTH LAST AND NEW COLUMN BY DISPLAYER.
  11085.     DVS(LR,LC)=DVS(LR,LC)+.0000000057
  11086.     DVS(DROW,DCOL)=DVS(DROW,DCOL)+.000000062
  11087. 7901    GOTO 9990
  11088. 8000    IF(CMDLIN(1).NE.'M')GOTO 8001
  11089.     ICODE=1
  11090. C MACROCELL COMMAND IF MH (HIDE) OR MS (SHOW)
  11091.     IF(CMDLIN(2).EQ.'S')IDOL4=1
  11092.     IF(CMDLIN(2).EQ.'H')IDOL4=0
  11093.     IF(CMDLIN(2).EQ.'S'.OR.CMDLIN(2).EQ.'H')GOTO 9990
  11094.     IF(CMDLIN(2).NE.'D')GOTO 4401
  11095. C MD MODE COMMAND.
  11096. C  MDD=DISABLE 3D AND DISALLOW 3D VBL NAMES
  11097. C  MDN=NO 3D BUT ALLOW 3D VBL NAMES
  11098. C  MDE=ENABLE 3D. DON'T TRANSLATE VARIABLE NAMES
  11099. C  MDF=FORCE 3D, TRANSLATING VARIABLE NAMES
  11100. C    ALL THESE ALLOW 2 NUMBERS TO FOLLOW, BEING COLUMN AND
  11101. C    ROW DELTAS TO THE NEXT "PLANE".
  11102.     K3DFG=0
  11103.     IF(CMDLIN(3).EQ.'D')K3DFG=-2
  11104.     IF(CMDLIN(3).EQ.'N')K3DFG=0
  11105.     IF(CMDLIN(3).EQ.'E')K3DFG=1
  11106.     IF(CMDLIN(3).EQ.'F')K3DFG=999
  11107. C NOW GRAB ARGS IF ANY.
  11108. C USE INTERNAL PROCEDURE TO DECODE 2 NUMBERS STARTING AT CMDLIN(4)
  11109. C SKIP IF NEXT CHAR IS NOT NUMERIC.
  11110.     If(cmdlin(4).eq.' ')goto 4404
  11111.     IF(Ichar(CMDLIN(4)).LE.47.OR.
  11112.      1   Ichar(CMDLIN(4)).GT.57)GOTO 9990
  11113. 4404    continue
  11114.     ASSIGN 4402 TO KBACK
  11115.     GOTO 8132
  11116. 4402    CONTINUE
  11117.     IF(NCL.GE.0.AND.NCL.LT.Mrows)KCDELT=NCL
  11118.     IF(LCWID.GE.0.AND.LCWID.LT.Mcols)KRDELT=LCWID
  11119.     GOTO 9990
  11120. 4401    CONTINUE
  11121. C MOVE COMMAND
  11122. C M1,M2,M3,M4 MOTION DIRECTION IS U,D,L,R
  11123.     IVVV=ICHAR(CMDLIN(2))
  11124. C ALLOW M0 TO MEAN RESTORE PRIOR STATE OF AUTOMOVE AND
  11125. C SAVE CURRENT STATE AS NEW PRIOR ONE. M1 THRU M5 MEAN SET
  11126. C AUTOMOVE TO 1-5 (5=NO MOTION) AND SAVE OLD STATE AS LAST
  11127. C STATE.
  11128.     IF(CMDLIN(2).EQ.'0')IVVV=JMVOLD
  11129.     JMVOLD=JMVFG
  11130.     JMVFG=IVVV
  11131. C    JMVFG=ICHAR(CMDLIN(2))
  11132. C STORE CHARACTER AS MOVE FLAG
  11133.     GOTO 9990
  11134. 8001    IF(CMDLIN(1).NE.'D')GOTO 8002
  11135. C DISPLAY COMMANDS
  11136. C
  11137. C DISPLAY SORT
  11138. C DSRA 1
  11139. C DS = CONSTANT KEYWORD
  11140. C R/C=ROW/COL (DISPLAY COORD #S)
  11141. C A/D=ASCENDING/DESCENDING ORDER
  11142. C NUMBER= DISPLAY COORD ROW/COL # TO SORT ON.
  11143. C SORTS NUMERIC FIELDS ONLY.
  11144.     IF(CMDLIN(2).NE.'S')GOTO 1752
  11145.     ICODE=2
  11146. C MUST REDRAW. WE DO WHOLESALE RELOCATIONS OF THINGS HERE.
  11147. C FIRST GET ARGUMENTS
  11148.     LAA=6
  11149.     LBB=15
  11150.     CALL GN(LAA,LBB,NBR,CMDLIN)
  11151. C THIS EXTRACTS THE NUMBER OF ROW/COL TO USE.
  11152. C DEFAULT IS PHYS, COL, ASCENDING
  11153. C    IF(NBR.LE.0.OR.NBR.GT.MAX0(20,75))GOTO 9990
  11154.     IF(NBR.LE.0.OR.NBR.GT.75)GOTO 9990
  11155.     SSIGN=1.
  11156.     IF(CMDLIN(4).EQ.'D')SSIGN=-1.
  11157. C SSIGN USED TO CONTROL ASCENDING/DESCENDING SORT (MULTIPLY BY IT)
  11158. C GET LENGTH TO GO THRU IN SORT
  11159.     IF(CMDLIN(3).EQ.'C')IDELTA=DCLV-1
  11160.     IF(CMDLIN(3).EQ.'R')IDELTA=DRWV-1
  11161.     I1IN=0
  11162.     I2IN=1
  11163. C GET PHYSICAL COORDINATES OF ROW/COL WE'RE SORTING ON.
  11164.     IF(CMDLIN(3).EQ.'R')GOTO 6222
  11165.     ID1=NRDSP(NBR,1)
  11166.     ID2=NCDSP(NBR,1)
  11167.     GOTO 1753
  11168. 6222    CONTINUE
  11169.     ID1=NRDSP(1,NBR)
  11170.     ID2=NCDSP(1,NBR)
  11171.     I1IN=1
  11172.     I2IN=0
  11173. C HACK TO HANDLE ROW/COL ALIKE
  11174. 1753    CONTINUE
  11175.     IFLIP=0
  11176. C IFLIP = BUBBLESORT FLAG WE CHANGED SOMETHING
  11177. C (USE SIMPLE MINDED SMALL SORT. TOO MUCH OVHD FOR BETTER ONE...NO ROOM)
  11178.     ID1A=ID1
  11179.     ID2A=ID2
  11180. C IGNORE CASE OF IDELTA=0... SHOULDN'T BE ANY WAY FOR THAT TO HAPPEN
  11181.     DO 1754 IV=1,IDELTA
  11182. C SORT HERE. IFLIP=1 IF WE INVERT ANYTHING.
  11183. C JUST COMPARE XVBLS...
  11184. C NOTE WE ASSUME A "NORMAL" TYPE DISPLAY, JUST RESET PHYSICAL STUFF.
  11185.     CALL XVBLGT(ID1A,ID2A,XAC)
  11186.     CALL XVBLGT(ID1A+I1IN,ID2A+I2IN,XVBLS(1,1))
  11187.     IF(XAC*SSIGN.LE.XVBLS(1,1)*SSIGN)GOTO 1755
  11188. C FLIP ASSIGNMENTS
  11189. C FLIP XVBLS NUMBERS TOO TO MAINTAIN SORT. WE RECOMPUTE ANYWAY..
  11190.     CALL XVBLST(ID1A+I1IN,ID2A+I2IN,XAC)
  11191.     CALL XVBLST(ID1A,ID2A,XVBLS(1,1))
  11192.     IFLIP=1
  11193. C SWAP ASSIGNMENTS OF DISPLAY STUFF IF IN RANGE
  11194. C OPERATES LIKE A SORTED OA COMMAND
  11195. C CURRENT PHYSICAL ROW IS ID2A (1...RCL LIMITS)
  11196. C AND PHYS COL IS ID1A.
  11197. C    LDELTA=DRW-1
  11198.     LDELTA=19
  11199. C FOR REASSIGNMENT, ROLE OF I1IN,I2IN CAN BE REVERSED...
  11200.     ID1B=1
  11201. C NOTE DISPLAY ID2 IS 1 LESS THAN PHYSICAL ONE. (AC'S)
  11202.     ID2B=ID2A-1
  11203.     IF(ID2B.LE.0)GOTO 1754
  11204.     IF(CMDLIN(3).NE.'R')GOTO 1756
  11205. C ROW...
  11206. C    LDELTA=DCL-1
  11207.     LDELTA=74
  11208. C ID1 SAME AS DISPLAY COORDS
  11209.     ID1B=ID1A
  11210.     ID2B=1
  11211. 1756    CONTINUE
  11212.     DO 1757 IVV=1,LDELTA
  11213. C FLIP THE ROW/COL 1 ENTRY AT A TIME. JUST CHANGES ASSIGNMENTS.
  11214.     JD1=NRDSP(ID1B,ID2B)
  11215.     JD2=NCDSP(ID1B,ID2B)
  11216.     NRDSP(ID1B,ID2B)=NRDSP(ID1B+I1IN,ID2B+I2IN)
  11217.     NCDSP(ID1B,ID2B)=NCDSP(ID1B+I1IN,ID2B+I2IN)
  11218.     NRDSP(ID1B+I1IN,ID2B+I2IN)=JD1
  11219.     NCDSP(ID1B+I1IN,ID2B+I2IN)=JD2
  11220.     ID1B=ID1B+I2IN
  11221.     ID2B=ID2B+I1IN
  11222. 1757    CONTINUE
  11223. C WE CAN ALWAYS FLIP SINCE WE STAY ON DISPLAY SHEET.
  11224. 1755    CONTINUE
  11225.     ID1A=ID1A+I1IN
  11226.     ID2A=ID2A+I2IN
  11227. 1754    CONTINUE
  11228. C DONE 1 PASS. IF ANYTHING CHANGED, TRY AGAIN.
  11229.     IF(IFLIP.NE.0)GOTO 1753
  11230. C DONE SORT AT END
  11231.     GOTO 9990
  11232. 1752    CONTINUE
  11233. C
  11234.     IF(CMDLIN(2).NE.'L')GOTO 8101
  11235. C DL = DISPLAY LOCATE V1:V2 N:M
  11236.     ASSIGN 8103 TO IBACK
  11237.     GOTO 8104
  11238. C STRIP VARIABLE NAMES OFF CMD LINE STARTING AT POSITION 3
  11239. 8104    LA=3
  11240.     LE=98
  11241.     L1=0
  11242.     LPagmd=0
  11243.     LPag1=0
  11244.     LPag2=0
  11245.     CALL VARSCN(CMDLIN(1),LA,LE,LSTC,ID1A,ID2A,IVLD)
  11246.     L2=0
  11247. C L1,L2 = FLAGS VARIABLE 1,2 FOUND VALIDLY
  11248.     LA=LSTC+1
  11249.     LE=100-LA
  11250.     IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8102
  11251.     L1=1
  11252.     lpag1=kpag
  11253.     IF(CMDLIN(LSTC).eq.'}')Lpagmd=1
  11254.     IF((CMDLIN(LSTC).NE.':').and.(Cmdlin(Lstc).ne.'}'))
  11255.      1   GOTO 8102
  11256.     IF(CMDLIN(LSTC).NE.':')GOTO 8102
  11257. C MUST SEE : BETWEEN NAMES. NO SPACES PERMITTED.
  11258.     CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1B,ID2B,IVLD)
  11259.     IF(IVLD.LE.0)GOTO 8102
  11260.     lpag2=kpag
  11261.     L2=1
  11262. 8102    CONTINUE
  11263. C NOTE THAT LSTC RETURNS AS CHARACTER AFTER VARIABLE LAST GRABBED IN INPUT LINE.
  11264.     GOTO IBACK,(8103,8112,8121,8301,8953,8900)
  11265. C NOW PICK UP RN:M OR CN:M (R=ROW,C=COL)
  11266. 8103    CONTINUE
  11267.     IF(L1.LT.1)GOTO 8101
  11268. C INVALID UNLESS AT LEAST 1 VBL NAME SEEN.
  11269.     LA=LSTC+2
  11270.     RCF=0
  11271.     IF(CMDLIN(LSTC+1).EQ.'R')RCF=2
  11272.     IF(CMDLIN(LSTC+1).EQ.'C')RCF=1
  11273.     IF(RCF.EQ.0)GOTO 8101
  11274.     KM1=1
  11275.     CALL GN(KM1,LE,NUM1,CMDLIN(LA))
  11276.     IF(NUM1.EQ.0)GOTO 8101
  11277.     KKK=ICHAR(':')
  11278.     LE=INDX(CMDLIN(LA),KKK)
  11279.     NUM2=0
  11280.     IF(LE.GT.100)GOTO 8101
  11281.     LA=LA+LE
  11282.     KM1=1
  11283.     KM8=8
  11284.     CALL GN(KM1,KM8,NUM2,CMDLIN(LA))
  11285. C NOW NUM1,NUM2 ARE DESIRED ROW/COL RANGE. NOW SET UP DISPLAY.
  11286.     IF(NUM2.EQ.0.OR.NUM2.GT.75)GOTO 8101
  11287.     IF(NUM1.GT.20)GOTO 8101
  11288. C ILLEGAL ROW/COL IS A NO-GO.
  11289. C R N:M MEANS STARTING AT COL N ROW M GOING L TO R.
  11290. C C N:M MEANS DOWN STARTING THERE. DISPLAY COORDS ASSUMED.
  11291.     IF(ID1A.NE.ID1B.AND.ID2A.NE.ID2B)GOTO 8101
  11292. C ONLY HANDLE ROWS OR COLS, NOT DIAGONALS.
  11293. C MUST BE A PHYS MTX ROW OR COL.
  11294.     LRINC=0
  11295.     LCINC=0
  11296.     IF(RCF.EQ.1)LRINC=1
  11297.     IF(RCF.EQ.2)LCINC=1
  11298.     ASSIGN 8108 TO JBACK
  11299.     GOTO 8109
  11300. C COPY DATA
  11301. 8109    CONTINUE
  11302.     ICODE=6
  11303.     IDELT=1
  11304.     IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B))+1
  11305.     I1IN=0
  11306.     I2IN=1
  11307.     IF(ID1A.EQ.ID1B)GOTO 8106
  11308.     I1IN=1
  11309.     I2IN=0
  11310. 8106    CONTINUE
  11311.     ID1=ID1A
  11312.     ID2=ID2A
  11313.     GOTO JBACK,(8108,8113,8122,8307,8954)
  11314. 8108    CONTINUE
  11315.     ICODE=1
  11316.     IR=NUM1
  11317.     IC=NUM2
  11318. C 1 DIM COPY OF DATA, FOR IDELT ELEMENTS.
  11319.     DO 8105 NM=1,IDELT
  11320. C CLAMP TO MAX DISPLAY ARRAY
  11321.     IF(IR.GT.20.OR.IC.GT.75)GOTO 8105
  11322.     NRDSP(IR,IC)=ID1
  11323.     NCDSP(IR,IC)=ID2
  11324.     DVS(IR,IC)=DVS(IR,IC)-1.E-14
  11325. C    THISRW=IR
  11326. C    THISCL=IC
  11327. C    JRX=(ID2-1)*60+ID1
  11328.     CALL REFLEC(ID2,ID1,JRX)
  11329.     CALL WRKFIL(JRX,FORM2,0)
  11330. C    READ(7'JRX)FORM2
  11331. C    DO 7104 N7=1,9
  11332. C7104    DFMTS(N7,IR,IC)=FORM2(N7+119)
  11333. C    DFMTS(10,IR,IC)=0
  11334.     IR=IR+LCINC
  11335.     IC=IC+LRINC
  11336. C NOTE REVERSAL FOR DISPLAY.
  11337.     ID1=ID1+I1IN
  11338.     ID2=ID2+I2IN
  11339. 8105    CONTINUE
  11340. 8101    CONTINUE
  11341.     IF(CMDLIN(2).NE.'F')GOTO 8111
  11342. C DF STUFF - SET FORMAT.
  11343.     ASSIGN 8112 TO IBACK
  11344.     GOTO 8104
  11345. 8112    CONTINUE
  11346. C NOW HAVE VARIABLE ID'S SET UP
  11347.     IF(L1.LE.0)GOTO 8120
  11348. C MUST HAVE 1 OR MORE...
  11349.     ASSIGN 8113 TO JBACK
  11350.     GOTO 8109
  11351. C IDELT NOW SET UP. SET FORMATS UP NOW.
  11352. C FORMATS ARE IN [] BRACKETS. FIND THESE AND USE.
  11353. 8113    CONTINUE
  11354.     ICODE=1
  11355.     KKK=ICHAR('[')
  11356.     LA=INDX(CMDLIN,KKK)+1
  11357.     KKK=ICHAR(']')
  11358.     LB=INDX(CMDLIN,KKK)-1
  11359.     LDELT=LB-LA+1
  11360.     LDELT=MIN0(LDELT,9)
  11361.     DO 8114 LN=1,IDELT
  11362. C IDELT IS OVER VRBL LIST GIVEN. MAY BE 1 ONLY.
  11363. C    IRRX=(ID2-1)*60+ID1
  11364.     CALL REFLEC(ID2,ID1,IRRX)
  11365.     CALL WRKFIL(IRRX,FORM,0)
  11366. C    READ(7'IRRX)FORM
  11367.     IF(CMDLIN(LA).EQ.'*')GOTO 7115
  11368.     IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')GOTO 7115
  11369. C KEEP EXISTING FORMAT IF [*] IS USED.
  11370.     DO 7989 KKKK=1,9
  11371. 7989    FORM(119+KKKK)=Char(0)
  11372.     DO 8115 LNA=1,LDELT
  11373.     FORM(LNA+119)=CMDLIN(LA-1+LNA)
  11374.     IF(LNA.LT.9)FORM(LNA+120)=0
  11375. 8115    CONTINUE
  11376. 7115    CONTINUE
  11377. C    FORM(128)=0
  11378.     CALL FVLDGT(ID1,ID2,FVWRK)
  11379.     IVVVV=JCHAR(FVWRK)
  11380.     IF(IVVVV.EQ.0)IVVVV=3
  11381. C SET UP DEFAULT AS NUMERIC.
  11382. C    IVVVV=FVLD(ID1,ID2)
  11383. C    FVLD(ID1,ID2)=MAX0(1,IABS(IVVVV))
  11384.     IVVVV=MAX0(1,IABS(IVVVV))
  11385.     IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')IVVVV=
  11386.      1  MIN0(-1,-IABS(IVVVV))
  11387.     CALL FVLDST(ID1,ID2,CHAR(IVVVV))
  11388.     IF(CMDLIN(LA).EQ.'I')CALL TYPSET(ID1,ID2,4)
  11389.     IF(CMDLIN(LA).EQ.'F'.OR.CMDLIN(LA).EQ.'E')
  11390.      1   CALL TYPSET(ID1,ID2,2)
  11391.     FORM(119)=CHAR(IVVVV)
  11392. C
  11393. C TO BE SURE WE DON'T FOUL UP THE FILE, TRY AN ENCODE ON THIS FORMAT
  11394. C PRIOR TO THE WRITE. THAT WAY IF WE BOMB, THE FILE WE HAVE DIRECT ACCESS
  11395. C DATA ON IS NOT CLOBBERED.
  11396.     IF(IVVVV.LE.0)GOTO 7990
  11397.     DO 7988 KKK=1,9
  11398.     KKKK=ICHAR(FORM(119+KKK))
  11399. 7988    DFE(KKK+1)=CHAR(MAX0(32,KKKK))
  11400.     DFE(1)='('
  11401.     DFE(12)=' '
  11402.     DFE(13)=' '
  11403.     DFE(14)=')'
  11404.     CALL TYPGET(N1,N2,TYPE(1,1))
  11405.     CALL FVLDGT(N1,N2,FVLD(1,1))
  11406.     IF(JCHAR(FVLD(1,1)).LE.0)GOTO 7990
  11407.     IF(TYPE(1,1).NE.2)GOTO 6223
  11408.     WRITE(WRKCHR(1:127),DFE,ERR=4302)DVS(THISRW,THISCL)
  11409.     GOTO 7990
  11410. 6223    CONTINUE
  11411.         WRITE(WRKCHR(1:127),DFE,ERR=4302)LDVS(1,THISRW,THISCL)
  11412. 7990    CONTINUE
  11413.     CALL WRKFIL(IRRX,FORM,1)
  11414.     DO 8116 NX1=1,20
  11415.     DO 8116 NX2=1,75
  11416. C LOCATE DISPLAY CELL IF ANY
  11417.     IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8117
  11418. 8116    CONTINUE
  11419.     GOTO 8118
  11420. 8117    CONTINUE
  11421.     DVS(NX1,NX2)=DVS(NX1,NX2)-1.23E-12
  11422. 8118    CONTINUE
  11423.     ID1=ID1+I1IN
  11424.     ID2=ID2+I2IN
  11425. 8114    CONTINUE
  11426. 8111    CONTINUE
  11427.     IF(CMDLIN(2).NE.'T')GOTO 8120
  11428. C DT DISPLAY TYPE
  11429.     ASSIGN 8121 TO IBACK
  11430.     GOTO 8104
  11431. C GET VBL NAMES
  11432. 8121    ASSIGN 8122 TO JBACK
  11433.     GOTO 8109
  11434. 8122    LA=LSTC+1
  11435.     IF(L1.LE.0)GOTO 8120
  11436.     KTYP=2
  11437.     IF(CMDLIN(LA).EQ.'I')KTYP=4
  11438.     ICODE=1
  11439.     DO 8123 LNA=1,IDELT
  11440.     CALL TYPSET(ID1,ID2,KTYP)
  11441. C    TYPE(ID1,ID2)=KTYP
  11442.     DO 8126 NX1=1,DRWV
  11443.     DO 8126 NX2=1,DCLV
  11444.     IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8127
  11445. C FIND DISPLAY LOC IF ANY AND SET IT UP FOR REDRAW
  11446. 8126    CONTINUE
  11447.     GOTO 8128
  11448. 8127    CONTINUE
  11449.     DVS(NX1,NX2)=DVS(NX1,NX2)-1.211E-16
  11450. 8128    CONTINUE
  11451.     ID1=ID1+I1IN
  11452.     ID2=ID2+I2IN
  11453. 8123    CONTINUE
  11454. 8120    CONTINUE
  11455.     IF(CMDLIN(2).NE.'W')GOTO 8130
  11456. C DW SETS COL WIDTH
  11457.     ASSIGN 8131 TO KBACK
  11458.     GOTO 8132
  11459. C GET 2 NUMBERS STARTING AT CMDLIN(4)
  11460. 8132    CONTINUE
  11461.     KM1=1
  11462.     KM6=6
  11463.     CALL GN(KM1,KM6,NCL,CMDLIN(4))
  11464.     KKK=ICHAR(',')
  11465.     LA=INDX(CMDLIN(4),KKK)
  11466. C COMMA MUST BE SEPARATOR
  11467.     LCWID=7
  11468.     IF(LA.GT.100)GOTO 8138
  11469.     KM1=1
  11470.     CALL GN(KM1,KM6,LCWID,CMDLIN(LA+4))
  11471. 8138    GOTO KBACK,(8131,8141,4402)
  11472. 8131    CONTINUE
  11473.     ICODE=6
  11474.     NCL=MAX0(1,NCL)
  11475.     NCL=MIN0(NCL,20)
  11476.     LCWID=MAX0(1,LCWID)
  11477.     LCWID=MIN0(LCWID,110)
  11478. C COL WIDTH IS 3 TO 110 CHARS.
  11479.     IF(NCL.GT.0)CWIDS(NCL)=LCWID
  11480. 8133    CONTINUE
  11481. 8130    CONTINUE
  11482.     IF(CMDLIN(2).NE.'B')GOTO 8140
  11483. C DB = BOUNDS ON ROW,COL
  11484.     ASSIGN 8141 TO KBACK
  11485.     GOTO 8132
  11486. C PARASITE OTHER CODE TO GET DIGITS
  11487. 8141    MC=NCL
  11488.     MR=LCWID
  11489.     MC=MIN0(MC,20)
  11490.     MR=MIN0(MR,75)
  11491. C CLAMP RANGE TO LEGAL
  11492.     IF(MC.GT.0)DRWV=MC
  11493.     IF(MR.GT.0)DCLV=MR
  11494.     ICODE=2
  11495. C REDRAW SCREEN WHEN BOUNDS CHANGE.
  11496. 8140    CONTINUE
  11497.     GOTO 9990
  11498. 8002    IF(CMDLIN(1).NE.'V')GOTO 8003
  11499. C VIEW REDRAW COMMAND
  11500.     IF(CMDLIN(2).EQ.'C'.OR.CMDLIN(2).EQ.'B')CALL SWSET(0)
  11501.     IF(CMDLIN(2).EQ.'I')CALL SWSET(1)
  11502.     IF(CMDLIN(2).EQ.'C'.OR.CMDLIN(2).EQ.'B')MODFLG=0
  11503.     IF(CMDLIN(2).EQ.'I')MODFLG=1
  11504. C VI MEANS VIEW IBM MODE, USING BIOS CALLS FOR DIRECT SCREEN OUTPUT.
  11505.     IF(CMDLIN(2).EQ.'C')CALL UVT100(20,0,0)
  11506.     IF(CMDLIN(2).EQ.'B')CALL UVT100(21,0,0)
  11507. C VC SETS VIEW COLOR MODE
  11508. C VB SETS VIEW B+W MODE
  11509. C REQUIRES UVTGEN MODULE...
  11510.     IF(CMDLIN(2).EQ.'H')GOTO 8320
  11511. 8324    CONTINUE
  11512.     PZAP=0
  11513.     FORMFG=0
  11514.     IF(CMDLIN(2).EQ.'F')FORMFG=1
  11515.     IF(CMDLIN(2).EQ.'M')PZAP=1
  11516.     ICODE=6
  11517.     IF(CMDLIN(2).EQ.'E')ICODE=1
  11518. C VE JUST TURNS ON VIEW MODE, DOESN'T REPAINT ALL.
  11519.     GOTO 9990
  11520. 8320    CONTINUE
  11521.     IF(CMDLIN(3).NE.'+'.AND.CMDLIN(3).NE.'-')GOTO 8324
  11522. C VH+ OR VH-, FLIP VIEW HACK TO SHOW PROGRESS
  11523. C DYMANICALLY
  11524.     IDOL8=1
  11525.     IF(CMDLIN(3).EQ.'-')IDOL8=0
  11526. C IDOL8 = 1 MEANS DO THE DISPLAY, 0 MEANS DON'T.
  11527.     ICODE=3
  11528.     GOTO 9990
  11529. 8003    IF(CMDLIN(1).NE.'C'.AND.CMDLIN(1).NE.'I')GOTO 8004
  11530. C COPY NUMBERS COMMAND
  11531. C COPY (NUMBERS,FORMAT,DISPLAY,ALL)
  11532. C CV=COPY VALUE, CD=COPY DISPLAY FMT, CF=COPY FORMULA, CA=COPY ALL
  11533. C Ca V1:V2 V3:V4 COPIES FIRST RANGE TO SECOND.
  11534. C IR RANGES DOES INPLACE RELOCATION...
  11535. C
  11536. C COLLECT ARGS
  11537.     ASSIGN 8301 TO IBACK
  11538.     GOTO 8104
  11539. 8301    CONTINUE
  11540. C NOW L1,L2 SAY IF VBLS(ID1A,ID2A) AND (ID1B,ID2B) EXIST
  11541. C also Lpagmd says if the first range is page range and
  11542. C Lpag1 and Lpag2 have page ranges.
  11543. C COLLECT JD2A,JD2B. USE SIMILAR INTERNAL PROCEDURE CODE.
  11544.     IF(L1.LE.0)GOTO 8399
  11545.     ASSIGN 8302 TO MBACK
  11546.     GOTO 8303
  11547. 8303    CONTINUE
  11548. C COLLECT 2 VARS STARTING AT LSTC+3
  11549. C SKIPS LSTC DELIMITER.
  11550.     LJ1=0
  11551.     LJ2=0
  11552.     LA=LSTC+1
  11553.     LE=110-LA
  11554.     KPagmd=0
  11555.     KPag1=0
  11556.     KPag2=0
  11557.     IF(LE.LE.0)GOTO 8304
  11558.     CALL VARSCN(CMDLIN,LA,LE,LSTC,JD1A,JD1B,IVLD)
  11559.     LA=LSTC+1
  11560.     LE=110-LA
  11561.     IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8304
  11562.     KPag1=kpag
  11563.     LJ1=1
  11564. C allow } to indicate DEPTH oriented ranges but flag it.
  11565.     If(Cmdlin(lstc).eq.'}')KPagmd=1
  11566.     IF((CMDLIN(LSTC).NE.':').and.(Cmdlin(Lstc).ne.'}'))
  11567.      1    GOTO 8304
  11568.     CALL VARSCN(CMDLIN,LA,LE,LSTC,JD2A,JD2B,IVLD)
  11569.     IF(IVLD.LE.0)GOTO 8304
  11570.     KPag2=kpag
  11571.     LJ2=1
  11572. 8304    GOTO MBACK,(8302)
  11573. 8302    CONTINUE
  11574.     IF(LJ1.LE.0)GOTO 8399
  11575.     IDELT=1
  11576.     IPDL=0
  11577.     If(LPagmd.ne.0.and.Lpag2.gt.LPag1)ipdl=Lpag2-Lpag1
  11578.     If(K3Dfg.le.0)ipdl=0
  11579.     IF(L2.NE.0.AND.(ID1A.NE.ID1B.AND.ID2A.NE.ID2B))GOTO 8305
  11580.     IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B),
  11581.      1   IPDL)+1
  11582.     if(k3dfg.gt.0.and.lpagmd.ne.0.and.ipdl.gt.0)
  11583.      1  idelt=ipdl+1
  11584.     IKDelt=IDelt
  11585. 8305    CONTINUE
  11586.     JDELT=1
  11587.     JPDL=0
  11588.     If(KPagmd.ne.0.and.Kpag2.gt.KPag1)JPDL=KPag2-KPag1
  11589.     If(K3Dfg.le.0)jpdl=0
  11590.     IF(LJ2.EQ.0)GOTO 8306
  11591.     IF(JD1A.NE.JD2A.AND.JD1B.NE.JD2B)GOTO 8306
  11592.     JDELT=MAX0(IABS(JD1A-JD2A),IABS(JD1B-JD2B),
  11593.      1    JPDL)+1
  11594. 8306    IF(L2.NE.0)JDELT=MIN0(IDELT,JDELT)
  11595. C For page mode, difference is depth, not row or cols.
  11596.     if(k3dfg.gt.0.and.kpagmd.ne.0.and.jpdl.gt.0)
  11597.      1  jdelt=jpdl+1
  11598. C CHANGE FOR REPLICATE :  JDELT CAN BE JUST JDELT IF L2=0
  11599.     ASSIGN 8307 TO JBACK
  11600. C 8109 IS WHERE WE SET UP I1IN AND I2IN ASSUMING THAT THE VARIABLES
  11601. C ARE SET PROPERLY. HANDLED AS AN INTERNAL PROCEDURE.
  11602.     GOTO 8109
  11603. 8307    CONTINUE
  11604. C 8109 procedure also resets IDELT
  11605.     If(k3dfg.gt.0)IDelt=IKDelt
  11606.     JIN1=1
  11607.     JIN2=0
  11608.     IF(JD1B.EQ.JD2B)GOTO 8308
  11609.     JIN1=0
  11610.     JIN2=1
  11611. 8308    CONTINUE
  11612. C
  11613. C Change for 3D depth ranges:
  11614. C Reset I1IN and I2IN to KRDELT and KCDELT if depth mode and
  11615. C 3D stuff enabled. Reset JIN1 and JIN2 likewise if depth
  11616. C mode there.
  11617. C This has the advantage that it allows cells to be copied
  11618. C from any one dimensional range to any other, even if one
  11619. C or both 1-D ranges are in depth. A certain amount of hacking
  11620. C can allow cells possibly to be copied in overlapping pages
  11621. C also (for stuff like matrix traces).
  11622.     If(K3DFG.LE.0)goto 8610
  11623.     If(LPagmd.le.0)goto 8611
  11624.     I1IN=KCDELT
  11625.     I2IN=KRDELT
  11626. 8611    Continue
  11627.     If(KPagmd.le.0)goto 8610
  11628.     JIN1=KCDELT
  11629.     JIN2=KRDELT
  11630. 8610    Continue
  11631. C CHANGE FOR REPLICATE: IF L2 IS 0 (NO 2ND SRC VARIABLE), NO BUMPS
  11632. C PAST THE SINGLE VARIABLE SPECIFIED.
  11633.     IF(L2.EQ.0)I1IN=0
  11634.     IF(L2.EQ.0)I2IN=0
  11635. C FOR PCC-PC DO RECALC ALWAYS TO ALLOW DISPLAY TO LOOK OK
  11636.     ICODE=3
  11637. C    ICODE=1
  11638. C FORCE RECALC IF ONLY 1 SOURCE VARIABLE.
  11639. C    IF(L2.EQ.0)ICODE=3
  11640.     JRTR=PROW
  11641.     JRTC=PCOL
  11642. C JRTR AND JRTC = RELOCATION THRESHOLDS
  11643. C CELLS ABOVE OR LEFT OF JRTR,JRTC WILL NOT BE RELOCATED IN A CR
  11644. C OPERATION. THIS WILL GENERALLY BE THE PHYSICAL COLUMN OR ROW
  11645. C OF THE CURRENT POSITION. CELLS LOWER OR EQUAL, OR TO THE RIGHT
  11646. C OF THE CURRENT LOCATION OR EQUAL, WILL BE RELOCATED. (VARIABLE
  11647. C NAMES GET EDITED)
  11648.     ASSIGN 8365 TO KPYBAK
  11649.     GOTO 8364
  11650. C 8364 BEGINS COPY PROCEDURE SECTION
  11651. C GOES FOR JDELT CELLS WITH I1IN AND I2IN BEING SOURCE INCREMENTS FOR
  11652. C RRW DIMENSION, RCL DIMENSION, AND JIN1,2 BEING INCREMENTS FOR
  11653. C DESTINATION RRW,RCL DIMENSIONS RESPECTIVELY. USES CMDLIN(2) TO
  11654. C FLAG WHETHER TO HANDLE ALL, JUST FORMAT, RELOCATE, ETC.
  11655. C  ALSO ID1A,ID2A ARE START SOURCE LOCATION
  11656. C  JD1A,JD1B = DEST START LOCATION.
  11657. C
  11658. C COPIES 1 ROW OR COLUMN AT A TIME.
  11659. 8364    CONTINUE
  11660. C    ICODE=1
  11661. C SET DISPLAY UPDATE ON COPIED CELLS
  11662. CCD    DO 3620 JV=1,BRRCL
  11663. CCD3620    IBITMP(JV)=0
  11664.     DO 8309 JV=1,JDELT
  11665.     DO 8380 NX1=1,DRWV
  11666.     DO 8380 NX2=1,DCLV
  11667. C LOCATE DISPLAY CELL IF ANY
  11668.     IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8387
  11669. 8380    CONTINUE
  11670.     GOTO 8388
  11671. 8387    CONTINUE
  11672.     DVS(NX1,NX2)=DVS(NX1,NX2)+1.245E-14
  11673. 8388    CONTINUE
  11674. C    JRXX=(JD1B-1)*60+JD1A
  11675. C    IRXX=(ID2A-1)*60+ID1A
  11676.     CALL REFLEC(JD1B,JD1A,JRXX)
  11677.     CALL REFLEC(ID2A,ID1A,IRXX)
  11678.     CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
  11679.     KKKKK=JCHAR(FVLD(1,1))
  11680.     CALL FVLDGT(JD1A,JD1B,FVLD(1,1))
  11681.     IF(KKKKK.EQ.0.AND.ICHAR(FVLD(1,1)).EQ.0)GOTO 8314
  11682. C    IF(FVLD(ID1A,ID2A).EQ.0.AND.FVLD(JD1A,JD1B).EQ.0)GOTO 8314
  11683.     CALL WRKFIL(IRXX,FORM,0)
  11684.     CALL WRKFIL(JRXX,FORM2,0)
  11685.     IF(KKKKK.EQ.-2)CALL FVLDST(ID1A,ID2A,CHAR(253))
  11686.     IF(KKKKK.EQ.2)CALL FVLDST(ID1A,ID2A,CHAR(3))
  11687.     IF(jchar(FORM (119)).EQ. 2)FORM (119)=Char(3)
  11688.     IF(jchar(FORM (119)).EQ.-2)FORM (119)=Char(253)
  11689.     IF(jchar(FORM2(119)).EQ. 2)FORM2(119)=Char(3)
  11690.     IF(jchar(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
  11691.     IF(CMDLIN(2).NE.'R'.AND.CMDLIN(2).NE.'A')GOTO 8310
  11692.     IF(CMDLIN(2).NE.'R')GOTO 8366
  11693. C RELOCATE, THEN WRITE NEW CELL
  11694.     II1=ID1A
  11695.     II2=ID2A
  11696.     JJ1=JD1A
  11697.     JJ2=JD1B
  11698.     CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC)
  11699. C THE ABOVE WILL RELOCATE FORM INTO FORM2 WHICH WE NOW EMIT.
  11700. C ALLOW IR COMMAND TO DO INPLACE RELOCATION.
  11701.     IF(CMDLIN(1).NE.'I')GOTO 6224
  11702.     CALL WRKFIL(IRXX,FORM2,1)
  11703.     GOTO 9222
  11704. 6224    CONTINUE
  11705.     CALL WRKFIL(JRXX,FORM2,1)
  11706.     GOTO 8367
  11707. 8366    CONTINUE
  11708.     CALL WRKFIL(JRXX,FORM,1)
  11709. C    WRITE(7'JRXX)FORM
  11710. 8367    CONTINUE
  11711.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  11712.     CALL TYPSET(JD1A,JD1B,TYPE(1,1))
  11713. C    TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A)
  11714.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  11715.     CALL XVBLST(JD1A,JD1B,XVBLS(1,1))
  11716. C    XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A)
  11717.     CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
  11718.     CALL FVLDST(JD1A,JD1B,FVLD(1,1))
  11719. C    FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A)
  11720. 9222    ID1A=ID1A+I1IN
  11721.     ID2A=ID2A+I2IN
  11722.     JD1A=JD1A+JIN1
  11723.     JD1B=JD1B+JIN2
  11724.     GOTO 8309
  11725. 8310    CONTINUE
  11726.     IF(CMDLIN(2).NE.'V')GOTO 8312
  11727.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  11728.     CALL TYPSET(JD1A,JD1B,TYPE(1,1))
  11729. C    TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A)
  11730.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  11731.     CALL XVBLST(JD1A,JD1B,XVBLS(1,1))
  11732. C    XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A)
  11733. 8312    IF(CMDLIN(2).NE.'D')GOTO 8313
  11734.     CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
  11735.     CALL FVLDST(JD1A,JD1B,FVLD(1,1))
  11736. C    FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A)
  11737.     DO 8315 LXQ=1,10
  11738. 8315    FORM2(118+LXQ)=FORM(118+LXQ)
  11739.     CALL WRKFIL(JRXX,FORM2,1)
  11740. C    WRITE(7'JRXX)FORM2
  11741. 8313    IF(CMDLIN(2).NE.'F')GOTO 8314
  11742.     DO 8316 LXQ=1,110
  11743. 8316    FORM2(LXQ)=FORM(LXQ)
  11744.     CALL WRKFIL(JRXX,FORM2,1)
  11745. 8314    CONTINUE
  11746.     ID1A=ID1A+I1IN
  11747.     ID2A=ID2A+I2IN
  11748.     JD1A=JD1A+JIN1
  11749.     JD1B=JD1B+JIN2
  11750. 8309    CONTINUE
  11751. C RETURN POINT FROM COPY LOOP IN NORMAL COPY
  11752.     GOTO KPYBAK,(8840,8836,8365)
  11753. 8365    CONTINUE
  11754. 8399    GOTO 9990
  11755. 8004    IF(CMDLIN(1).LT.'1'.OR.CMDLIN(1).GT.'4')GOTO 8005
  11756. C 1,2,3,4 POSITIONING COMMANDS
  11757. C USE LLT AND LGT LEXICAL ORDERING TESTS, NOT ARITHMETIC ONES...
  11758.     ICODE=5
  11759. C    IF(CMDLIN(1).EQ.'3')THISRW=MAX0(1,(THISRW-1))
  11760. C    IF(CMDLIN(1).EQ.'4')THISRW=MIN0((THISRW+1),DRWV)
  11761. C    IF(CMDLIN(1).EQ.'1')THISCL=MAX0(1,(THISCL-1))
  11762. C    IF(CMDLIN(1).EQ.'2')THISCL=MIN0((THISCL+1),DCLV)
  11763. C COULD ADD SCROLLING HERE IF DESIRED.
  11764. C    ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL.
  11765.     MVFG=ICHAR(CMDLIN(1))
  11766.     LRO=1
  11767.     LCO=1
  11768.     ID1=NRDSP(1,1)
  11769.     ID2=NCDSP(1,1)
  11770.     IF(.NOT.(MVFG.EQ.51.AND.THISRW.EQ.1))GOTO 2110
  11771. C MUST SCROLL LEFT
  11772.     IF(IDOL7.EQ.0)GOTO 2110
  11773.     IF(ID1.LE.1)GOTO 2110
  11774.     ID1=MAX0(1,ID1-DRWV+2)
  11775.     DROW=MAX0(1,DRWV-2)
  11776.     IQQ=1
  11777.     GOTO 7112
  11778. 2110    IF(MVFG.EQ.51)THISRW=MAX0(1,(THISRW-1))
  11779.     IF(.NOT.(MVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 2116
  11780. C MUST SCROLL RIGHT
  11781.     IF(IDOL7.EQ.0)GOTO 2116
  11782.     DROW=3
  11783. C    ID1=MIN0(60,ID1+DRWV-MIN0(DRWV,2))
  11784.     ID1=ID1+DRWV-MIN0(DRWV,2)
  11785.     IQQ=1
  11786.     GOTO 7112
  11787. C 7112 FAKES OUT OA CALL TO SCROLL OVER.
  11788. 2116    IF(MVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV)
  11789.     IF(.NOT.(MVFG.EQ.49.AND.THISCL.EQ.1))GOTO 2117
  11790. C MUST SCROLL UP
  11791.     IF(IDOL7.EQ.0)GOTO 2117
  11792.     IF(ID2.LE.2)GOTO 2117
  11793.     DCOL=MAX0(1,DCLV-2)
  11794.     ID2=MAX0(2,ID2-DCLV+2)
  11795.     IQQ=1
  11796.     GOTO 7112
  11797. 2117    IF(MVFG.EQ.49)THISCL=MAX0(1,(THISCL-1))
  11798.     IF(.NOT.(MVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 2118
  11799. C MUST SCROLL DOWN
  11800.     IF(IDOL7.EQ.0)GOTO 2118
  11801.     DCOL=3
  11802. C    ID2=MIN0(301,ID2+DCLV-MIN0(DCLV,2))
  11803.     ID2=ID2+DCLV-MIN0(DCLV,2)
  11804.     IQQ=1
  11805.     GOTO 7112
  11806. 2118    IF(MVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV)
  11807.     PROW=NRDSP(THISRW,THISCL)
  11808.     PCOL=NCDSP(THISRW,THISCL)
  11809.     DROW=THISRW
  11810.     DCOL=THISCL
  11811.     GOTO 9990
  11812. 8005    CONTINUE
  11813. 8007    IF(CMDLIN(1).NE.'R')GOTO 8008
  11814.     IF(CMDLIN(2).NE.'B')GOTO 7333
  11815. C RB VAR SETS RELOCATE BOUNDARY TO VAR COORDS
  11816.     IF(CMDLIN(3).EQ.'*')GOTO 7332
  11817. C NORMAL RB COMMAND
  11818. C RB VAR USES VAR NAME TO RESET BDY
  11819.     LO=3
  11820.     KKKK=20
  11821.     CALL VARSCN(CMDLIN,LO,KKKK,IV,ID1,ID2,IVALID)
  11822.     IF(IVALID.LE.0)GOTO 9990
  11823. C IGNORE ERRORS
  11824.     IDOL5=ID1
  11825.     IDOL6=ID2
  11826.     GOTO 9990
  11827. 7332    IDOL5=20000
  11828.     IDOL6=20000
  11829. C RB* RESETS RELOCATE BDY TO END OF SHEET
  11830.     GOTO 9990
  11831. 7333    CONTINUE
  11832. C RECOMPUTE SHEET.
  11833. C RM COMMAND SETS MANUAL FLAG.
  11834.     RCFGX=0
  11835. c
  11836.     RCONE=0
  11837.     IF(CMDLIN(2).NE.'S')GOTO 5114
  11838.     RRWACT=MCols
  11839.     RCLACT=MRows
  11840. 5114    CONTINUE
  11841. C RCFGX NONZERO INHIBITS RECALCULATION.
  11842. C RCONE SET 1 TO FORCE RECALC OF ALL.
  11843. C CHANGE FROM OTHER SYNTAX: RF FORCES RECALC, R DOES NOT.
  11844.     IF(CMDLIN(2).EQ.'F'.OR.CMDLIN(2).EQ.'R')RCONE=1
  11845. C NOTE RXF (X=ANY CHAR BUT F) ACTS LIKE OLD VERSION RXF.
  11846. C BARE R COMMAND HOWEVER JUST REDOES CALC. F NOW MEANS "FORCE"
  11847. C AND SEEMS A BIT MORE MNEMONIC THIS WAY. ALLOW RR COMMAND
  11848. C TO WORK AS WELL AS RF.
  11849.     IF(CMDLIN(2).NE.'R')RCMODE=0
  11850.     IF(CMDLIN(2).EQ.'E')RCMODE=1
  11851.     IF(CMDLIN(2).EQ.'I')RCMODE=2
  11852. C RE, RI MODE CONTROLS... ALSO RR ACTS LIKE RF BUT STAYS IN
  11853. C RE OR RI MODE... RECALC ENTRY OR INCREMENTAL...
  11854.     IF(CMDLIN(2).EQ.'M')RCFGX=1
  11855.     ICODE=3
  11856. C 3rd char I Inhibits recalc this time but sets modes...
  11857.     IF(CMDLIN(3).EQ.'I')ICODE=1
  11858.     GOTO 9990
  11859. 8008    IF(CMDLIN(1).NE.'K')GOTO 8009
  11860. C DROP INTO CALC BARE.
  11861.     IF(IPSET.NE.0)GOTO 9990
  11862. C CAN'T CALL CALC RECURSIVELY
  11863.     OSWIT=0
  11864.     ILNFG=0
  11865. C    ICODE=-1
  11866. C CLOSE UNIT 1 JUST IN CASE...
  11867.     CLOSE(1)
  11868.     CALL UVT100(11,2,0)
  11869. C ERASE DSPLY
  11870.     KLVL=1
  11871.     ILNCT=0
  11872. C ICODE SET TO 420 SPECIAL CODE TO TELL MAIN PGM TO CALL INTERACTIVE
  11873. C CALCULATOR FCN.
  11874.     ICODE=420
  11875.     GOTO 9990
  11876. 8009    IF(CMDLIN(1).NE.'L')GOTO 8010
  11877. C LOCATE CURSOR ORIGIN
  11878. C FORMAT IS L VARIABLE
  11879. C ONLY 1 VARIABLE NAME TO BE ENTERED.
  11880.     LA=2
  11881.     LE=30
  11882.     CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1A,ID2A,IVLD)
  11883.     L1=IVLD
  11884. C    ASSIGN 8900 TO IBACK
  11885. C    GOTO 8104
  11886. 8900    IF(L1.LT.1)GOTO 9990
  11887. 3800    PROW=ID1A
  11888.     PCOL=ID2A
  11889. C LOOK UP DISPLAY COORDS IF ANY
  11890.     ASSIGN 8901 TO NBK
  11891.     GOTO 7905
  11892. 8901    CONTINUE
  11893.     DROW=LR
  11894.     DCOL=LC
  11895.     THISRW=LR
  11896.     THISCL=LC
  11897. 3801    ICODE=1
  11898.     GOTO 9990
  11899. 8010    CONTINUE
  11900.     IF(CMDLIN(1).NE.'>')GOTO 3802
  11901. C >STRING SEARCHES FORMULAE FOR STRING
  11902.     LA=MIN0(IDOL5,RRWACT)
  11903.     LB=MIN0(IDOL6,RCLACT)
  11904. C NO ACTION UNLESS VALID SEARCH REGION (CURRENT TO RELOC BDY)
  11905. C EXISTS.
  11906.     IF(LA.LT.PROW.OR.LB.LT.PCOL)GOTO 3801
  11907.     DO 3803 ID1=PROW,LA
  11908.     DO 3803 ID2=PCOL,LB
  11909.     ID1A=ID1
  11910.     ID2A=ID2
  11911.     CALL FVLDGT(ID1,ID2,FVLD(1,1))
  11912.     IF(JCHAR(FVLD(1,1)).EQ.0)GOTO 3803
  11913. C HAVE VALID CELL HERE, SO GRAB ITS FORMULA AND COMPARE FOR THE ONE
  11914. C WE'RE LOOKING FOR. IF CMD LINE STARTS WITH >> ANCHOR THE SEARCH AT 1ST
  11915. C COL.
  11916.     LMX=50
  11917.     LMN=2
  11918.     IF(CMDLIN(2).NE.'>')GOTO 3805
  11919.     LMX=1
  11920.     LMN=3
  11921. 3805    CONTINUE
  11922. C    IRX=(ID2-1)*60+ID1
  11923.     CALL REFLEC(ID2,ID1,IRX)
  11924.     CALL WRKFIL(IRX,FORM,0)
  11925.     CALL CE2A(FORM,FORM2)
  11926.     DO 3804 IV=1,LMX
  11927.     KKKK=109-IV
  11928. C COMPARE FORMULA TEXT. USE EXISTING SCMP ROUTINE.
  11929.     CALL SCMP(CMDLIN(LMN),FORM2(IV),KKKK,KKK)
  11930.     IF(KKK.EQ.1.AND.JCHAR(FORM2(IV)).GT.0)GOTO 3800
  11931.     IF(JCHAR(FORM2(IV)).LE.0)GOTO 3803
  11932. 3804    CONTINUE
  11933. 3803    CONTINUE
  11934. C IF WE FALL THROUGH, WE FAILED TO FIND FORMULA SO FORGET IT.
  11935.     GOTO 3801
  11936. 3802    CONTINUE
  11937.     IF(CMDLIN(1).NE.'Z')GOTO 8011
  11938. C ZERO COMMAND
  11939. C ZA OR ZE V1:V2
  11940.     IF(CMDLIN(2).NE.'A')GOTO 8950
  11941. C ZA = ZERO ALL. BE SURE HE MEANS IT.
  11942.     CALL UVT100(1,LLDSP,1)
  11943. c    WRITE(0,8951)
  11944. c8951    FORMAT('Really Zero All of sheet [Y/N]?\')
  11945.     call Vwrt('Really Zero ALL of sheet [Y/N]?',31)
  11946.     III=IOLVL
  11947. C    IF(III.EQ.5)III=0
  11948.     if(iii.ne.11)READ(III,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4)
  11949.     if(iii.eq.11)call vget(form2,4)
  11950. 8952    FORMAT(4A1)
  11951.     ICODE=6
  11952.     IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990
  11953.     CALL UVT100(11,2,0)
  11954.     ICODE=-4
  11955.     GOTO 9990
  11956. 8950    IF(CMDLIN(2).NE.'E')GOTO 9990
  11957.     ASSIGN 8953 TO IBACK
  11958.     GOTO 8104
  11959. C GET NAMES
  11960. 8953    IF(L1.LE.0)GOTO 9990
  11961.     ASSIGN 8954 TO JBACK
  11962.     GOTO 8109
  11963. 8954    CONTINUE
  11964.     DO 8955 NI=1,128
  11965. 8955    FORM2(NI)=0
  11966.     FORM2(118)=Char(15)
  11967.     DO 8823 NI=1,9
  11968. 8823    FORM2(119+NI)=DEFVB(1+NI)
  11969.     DO 8956 NI=1,IDELT
  11970. C    IRX=(ID2-1)*60+ID1
  11971.     CALL REFLEC(ID2,ID1,IRX)
  11972.     CALL WRKFIL(IRX,FORM2,1)
  11973.     CALL FVLDST(ID1,ID2,CHAR(0))
  11974.     CALL XVBLST(ID1,ID2,0.0D0)
  11975.     IPRS=PROW
  11976.     IPCS=PCOL
  11977.     PROW=ID1
  11978.     PCOL=ID2
  11979.     ASSIGN 8957 TO NBK
  11980. C FIND DISPLAY LOC IF ANY
  11981.     GOTO 7905
  11982. 8957    PROW=IPRS
  11983.     PCOL=IPCS
  11984.     IF(LR.EQ.0.OR.LC.EQ.0)GOTO 8958
  11985.     DVS(LR,LC)=DVS(LR,LC)+1.E-11
  11986. 8958    CONTINUE
  11987.     ID1=ID1+I1IN
  11988.     ID2=ID2+I2IN
  11989. 8956    CONTINUE
  11990.     GOTO 9990
  11991. 8011    IF(CMDLIN(1).NE.'X')GOTO 8012
  11992. C EXIT TO OS
  11993. C SINCE THERE'S NO WORKFILE HERE, MAKE SURE HE MEANS IT...
  11994.     IF(IPSET.NE.0)GOTO 9990
  11995.     ICODE=2
  11996.     CALL UVT100(1,LLDSP,1)
  11997.         call 
  11998.      1 swrt('Exit now may lose data unless sheet has been saved'
  11999.      2 ,50)
  12000.     CALL UVT100(1,LLCMD,1)
  12001.     call Vwrt('Confirm Exit Request [Y/N]:',27)
  12002.     III=IOLVL
  12003. C    IF(IOLVL.EQ.5)III=0
  12004.     if(iii.ne.11)READ(III,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4)
  12005.     if(iii.eq.11)call vget(form2,4)
  12006.     IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990
  12007. C END CALL TO GET OUT OF HERE
  12008. c    Close(unit=11)
  12009.     Close(unit=3)
  12010.     Call TTYDEI
  12011.         STOP
  12012. C    CALL EXIT
  12013. 8012    IF(CMDLIN(1).NE.'S')GOTO 8013
  12014. C SAVE SHEET TO DISK (NEW SET OF DATA)
  12015. C NOW JUST PERMITS RESTART...
  12016.     ICODE=-2
  12017.     ISTAT=-2
  12018.     CALL UVT100(11,2,0)
  12019.     GOTO 9990
  12020. 8013    IF(CMDLIN(1).NE.'P')GOTO 8014
  12021.     IRTN=0
  12022.     CALL PGET(CMDLIN,ICODE,IRTN)
  12023.     IF(IRTN.EQ.1)GOTO 510
  12024.     GOTO 9990
  12025. 8014    CONTINUE
  12026. 8015    IF(CMDLIN(1).NE.'G')GOTO 8016
  12027. C GET INPUT NUMBERS OFF SEQUENTIAL FILE. USE CURRENT ORIGIN
  12028.     ICODE=2
  12029.     IRTN=0
  12030.     CALL PGGET(CMDLIN,ICODE,IRTN)
  12031.     IF(IRTN.EQ.1)GOTO 510
  12032. C FLAG WE NEED AT LEAST ONE FULL CALC BEFORE GOING TO PARTIALS...
  12033. C (OK TOO IF IN OLD RCMODE=0 MODE)
  12034.     RCMODE=-IABS(RCMODE)
  12035.     GOTO 9990
  12036. 8016    IF(CMDLIN(1).NE.'W')GOTO 8017
  12037. C WRITE (PRINT) SCREEN OUT TO FILE (MAY BE PRINTER)
  12038. C    CALL DSPSHT(10)
  12039. C    ICODE=1
  12040.     ICODE=400
  12041. C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
  12042.     GOTO 9990
  12043. 8017    CONTINUE
  12044.     IF(CMDLIN(1).NE.'H')GOTO 5019
  12045.     IF(IPSET.NE.0)GOTO 9990
  12046.     IVVV=0
  12047.     IVVVV=ICHAR(CMDLIN(2))
  12048.     ivvx=ICHAR(cmdlin(3))
  12049. 9308    CONTINUE
  12050.     IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
  12051.     if(ivvx.lt.48.or.ivvx.gt.57)goto 9381
  12052. c implement 2 digit help code.
  12053.     ivvvx=ivvx-48
  12054.     ivvv=(ivvv*10)+ivvvx
  12055.     ivvv=min0(ivvv,99)
  12056. 9381    continue
  12057. C SELECT HELP LEVEL 0-9 IF SPECIFIED.
  12058.     ICODE=30+IVVV
  12059.     GOTO 9990
  12060. 5019    CONTINUE
  12061. C *** ALLOW EVALUATION OF A CELL TO PERMIT INTERACTIVE COMMAND FILES TO
  12062. C *** BE CONTROLLED RATIONALLY. KEYWORD IS "TEST"
  12063.     IF(CMDLIN(1).NE.'T'.OR.CMDLIN(2).NE.'E')GOTO 4302
  12064. C TEST EXPRESSION IS SYNTAX.
  12065. C COPY CMDLIN INTO XTNCMD AND FLAG VIA ICODE=430
  12066.     XTNCNT=0
  12067.     ICODE=430
  12068.     DO 4307 N=1,80
  12069. 4307    XTNCMD(N)=Char(0)
  12070. C FIRST ZERO OUT EXTERNAL CMD LINE, THEN FILL IN WHAT'S NEEDED.
  12071.     DO 4303 N=1,79
  12072.     XTNCMD(N)=CMDLIN(3+N)
  12073. C ALLOW "TE <ANY EXPRESSION>" WITH OPTIONAL SPACE. JUST RETURNS VALUE IN
  12074. C % VARIABLE.
  12075.     IF(ICHAR(XTNCMD(N)).LT.32)GOTO 4304
  12076.     XTNCNT=N
  12077. 4303    CONTINUE
  12078. 4304    CONTINUE
  12079.     XTNCMD(XTNCNT+1)=Char(0)
  12080.     GOTO 9990
  12081. 4302    CONTINUE
  12082. C LET DOUBLE DOT (..) INDICATE TO GO BACK TO CONSOLE, CLOSING INPUT FILE
  12083.     IF (CMDLIN(1).EQ.'.'.AND.CMDLIN(2).EQ.'.')GOTO 510
  12084. C ELSE PRINT MESSAGE THAT WE DON'T UNDERSTAND THAT ONE & GO ON
  12085. C PRINT INVALID CMD MSG IF NOT JUST A SPACE OR C.R.
  12086.     IF(ICHAR(CMDLIN(1)).GT.32)CALL SWRT('Invalid Command.',16)
  12087.     GOTO 200
  12088. C ERROR ON READIN ADDRESS. REWIND TERMINAL IF USER
  12089. C TYPES CTRL Z (EOF), ELSE LEAVE INDIRECT FILES.
  12090. 510    CONTINUE
  12091. C    IF(IOLVL.EQ.5)REWIND 5
  12092.     CLOSE(3)
  12093. c    CLOSE(11)
  12094. c    Rewind 11
  12095. c    OPEN(11,FILE='CON:0/0/100/100/Analy Command')
  12096.     IOLVL=11
  12097.     GOTO 498
  12098. 9990    CONTINUE
  12099. C HERE CLEAN UP AND RETURN
  12100. C FIRST DISPLAY LAST CURRENT COL IN NORMAL VIDEO
  12101.     IF(IXLSTR.LE.0.OR.IXLSTC.LE.0)GOTO 2000
  12102.     N1=NRDSP(IXLSTR,IXLSTC)
  12103.     N2=NCDSP(IXLSTR,IXLSTC)
  12104. C    IRRX=(N2-1)*60+N1
  12105.     CALL REFLEC(N2,N1,IRRX)
  12106. C REWRITE LAST LOCATION WITH NO REVERSE VIDEO.
  12107. C    IF(FVLD(N1,N2).EQ.0)GOTO 2000
  12108.     IF(IXLSTC.GT.DCLV.OR.IXLSTR.GT.DRWV)GOTO 2000
  12109. C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED.
  12110.     IF(ICODE.LT.0.OR.ICODE.EQ.2)GOTO 2000
  12111. C NO SENSE REDRAWING IF WE'RE ABOUT TO ERASE DISPLAY ANYWAY.
  12112.     IF(ICODE.GT.30)GOTO 2000
  12113.     J=8
  12114. C ADD 6 COLS FOR LABELS
  12115. C DROW,DCOL IS CURRENT DISPLAY LOC.
  12116.     DO 3301 M1=1,IXLSTR
  12117. C FIND DISPLAY COLUMN TO USE
  12118. 3301    J=J+CWIDS(M1)
  12119.     J=J-CWIDS(IXLSTR)
  12120. C USE THISCL+1 TO LET 1ST ROW BE LABELS.
  12121.     ICCC=IXLSTC+2
  12122. C JVTINC = 1 IF VT100, 0 IF VT52
  12123. C JVTINC NEEDED SINCE UVT100 FOR VT100 DOES BACKSPACE AT THE SGR ENTRY
  12124. C AND THUS WE NEED TO CORRECT FOR IT. THIS WAS FIXED IN THE UVT52
  12125. C VERSION AND ITS DESCENDANTS.
  12126.     IC1POS=N1
  12127.     IC2POS=N2
  12128.     IF(PZAP.NE.0)GOTO 2000
  12129.     CALL UVT100(1,ICCC,J)
  12130. C SELECT ROW "IXLSTC", COL "J"
  12131.     CALL UVT100(13,0,0)
  12132. C DESELECT REVERSE VIDEO
  12133.     CALL FVLDGT(N1,N2,FVLDTP)
  12134.     ivv=min0(30,cwids(IXLSTR))
  12135.     IF(ICHAR(FVLDTP).EQ.0)CALL SWRT(BLANKS,IVV)
  12136.     IF(ICHAR(FVLDTP).EQ.0)GOTO 2000
  12137.     CALL WRKFIL(IRRX,FORM2,0)
  12138.     CALL CE2A(FORM2,FORM)
  12139. C    READ(7'IRRX)FORM
  12140.     DO 5546 KKKK=1,100
  12141.     IV=ICHAR(FORM(KKKK))
  12142.     IV=MAX0(IV,32)
  12143. 5546    FORM(KKKK)=Char(IV)
  12144.     IF(JCHAR(FVLDTP).LT.0.OR.FORMFG.NE.0)
  12145.      1  WRITE(CMDLNA(1:127),8201)(FORM(II),II=1,100)
  12146. C FILL IN TEXT FOR FORMULA IF FVLD < 0 HERE; BELOW, FILL IN VALUE TEXT IF FVLD
  12147. C > 0.
  12148.     IF(FORMFG.NE.0)GOTO 4324
  12149. C ALWAYS DO FORMULAS IF FORMFG SET (VF MODE).
  12150.     DO 6302 KKK=1,9
  12151.     KKKK=ICHAR(FORM(KKK+119))
  12152. C    KKKK=DFMTS(KKK,IXLSTR,IXLSTC)
  12153. 6302    DFE(KKK+1)=CHAR(MAX0(32,KKKK))
  12154.     DFE(11)=char(32)
  12155. C 32 = ASCII SPACE
  12156.     DFE(1)='('
  12157. C REMEMBER: NO \ EDITING IN INTERNAL WRITES!
  12158.     DFE(12)=' '
  12159.     DFE(13)=' '
  12160.     DFE(14)=')'
  12161.     CALL TYPGET(N1,N2,TYPE(1,1))
  12162.     IF(JCHAR(FVLDTP).LE.0)GOTO 4324
  12163.     IF(TYPE(1,1).NE.2)GOTO 6226
  12164.         WRITE(CMDLNA(1:127),DFE,ERR=4324)DVS(IXLSTR,IXLSTC)
  12165.     GOTO 4324
  12166. 6226    CONTINUE
  12167.     WRITE(CMDLNA(1:127),DFE,ERR=4324)LDVS(1,IXLSTR,IXLSTC)
  12168. C REDRAW THIS COL. WITHOUT REVERSE VIDEO HERE.
  12169. 4324    CALL SWRT(CMDLIN,CWIDS(IXLSTR))
  12170. C NOTE THIS REDRAWS PREVIOUS COL. IN NORMAL VIDEO.
  12171. C NO CARRIAGE CTL
  12172. 2000    CONTINUE
  12173. C NOW COMPLETE ANY CLEANUP.
  12174. C SET CMDLIN TO 0 AT START TO INHIBIT ANY MISINTERPRETATION.
  12175. C WE USE CMDLIN AS A BUFFER IN REDRAWIND DSPLY SO DON'T LET IT GET
  12176. C CLOBBERED.
  12177.     DO 945 K=1,132
  12178. 945    CMDLIN(K)=Char(0)
  12179.     RETURN
  12180.     END
  12181.  
  12182. C *************** AnalyNS.Ftn #####################################
  12183. c -h- nextel.fms    Tue Sep  2 10:58:55 1986    
  12184.     SUBROUTINE NEXTEL (RETVAL,RETTYP,RETCD)
  12185. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  12186. C ALL RIGHTS RESERVED
  12187. C
  12188. C  SCANS LINE(80) FROM NONBLK+1 AND RETURNS THE NEXT ELEMENT.
  12189. C  THIS ELEMENT COULD BE A CONSTANT, VALUE OF A VARIABLE, A
  12190. C  BINARY FUNCTION CODE, OR A UNARY FUNCTION CODE. UPON RETURN,
  12191. C  NONBLK POINTS TO LAST CHARACTER OF NEXT ELEMENT.
  12192. C
  12193. C  RETCD  =    1  IF OPERAND (VALUE IN RETVAL(100)
  12194. C        2  IF OPERATOR (VALUE IN RETTYP)
  12195. C        3  NO MORE ELEMENTS
  12196. C        4  IF ERROR
  12197. C
  12198. C  RETVAL  HOLDS VALUE OF OPERAND FOUND (EITHER CONSTANT OR IF
  12199. C       A VARIABLE (A-Z,%), THE VALUE OF THAT VARIABLE)
  12200. C
  12201. C  RETTYP  IS THE TYPE CODE
  12202. C NEXTEL CALLS
  12203. C
  12204. C ERRMSG     PRINTS OUT ERROR MESSAGES
  12205. C FLIP       REVERSES THE NON-LEADING ZERO DIGITS IN A VECTOR
  12206. C GETNNB     GETS THE NEXT NON-BLANK FROM LINE(80)
  12207. C
  12208. C NEXTEL IS CALLED BY INPOST
  12209. C
  12210. C
  12211. C    VARIABLE    USE
  12212. C    ---------   ----------------------------------
  12213. C
  12214. C    ALPHA(27)   HOLDS LEGAL VARIABLE NAMES.
  12215. C
  12216. C    ARROW       '^'
  12217. C
  12218. C    B10         SWITCH SET WHEN CONSTANT IS NOT OCTAL (MAY BE
  12219. C                DECIMAL OR HEX BECAUSE THE DIGIT 8 OR 9 WAS FOUND).
  12220. C
  12221. C    B16         SWITCH SET WHEN CONSTANT IS HEXADECIMAL BECAUSE
  12222. C                DIGIT A, B, C, D, E, OR F WAS FOUND.
  12223. C
  12224. C    BASE        HOLDS BASE OF CONSTANT.
  12225. C
  12226. C    CHAR1       HOLDS A SINGLE CHARACTER FROM LINE.
  12227. C
  12228. C    DEFBAS      THE DEFAULT BASE SPECIFIED.
  12229. C
  12230. C    DIGITS(16,3) HOLDS ASCII CHARACTERS FOR THE DIGITS OF BASES
  12231. C                 8, 10, AND 16.
  12232. C
  12233. C    DOT          '.'
  12234. C
  12235. C    EQ           '='
  12236. C
  12237. C    EXCODE       CODE FOR EXPONENTIATION.
  12238. C
  12239. C    FCNT         NUMBER OF UNARY FUNCTIONS DEFINED BY VECTOR FUNCT
  12240. C
  12241. C    FUNCT (NAME,INDXX) HOLDS FUNCTION NAMES.
  12242. C
  12243. C    FUNVAL(I,J)
  12244. C     IF I=1, THE VALUE IS THE NUMBER OF CHARACTERS IN THE J-TH
  12245. C             FUNCTION WHOSE NAME IS THE FUNCT(K,J) WHERE K=1,2,3...10
  12246. C     IF I=2, THE VALUE IS THE STACK ELEMENT CODE FOR THE J-TH
  12247. C             FUNCTION WHOSE NAME IS IN FUNCT(K,J), K=1,2,3...10
  12248. C
  12249. C
  12250. C    I,J,K,L  HOLDS TEMPORARY VALUES
  12251. C
  12252. C    I1,I2    HOLD VALUE OF DIGITS IN E OR D SPECIFICATION.
  12253. C
  12254. C    IALPHA   INDEX INTO ALPHA OF THE FIRST NON-BLANK CHARACTER FOUND.
  12255. C
  12256. C    IHOLD    HOLDS TEMPORARY VALUES
  12257. C
  12258. C    INT      PICKS UP INTEGER*4 VALUES.
  12259. C
  12260. C    IPT      POINTER TO ELEMENTS IN LINE(80).
  12261. C
  12262. C    IPT2     POINTER TO ELEMENTS IN LINE(80).
  12263. C
  12264. C    LASTOP  USED TO HOLD VALUE OF LAST OPERATOR SO THAT UNARY OPERATORS
  12265. C            CAN BE IDENTIFIED IN CASES LIKE A*-B AND A/(-3).
  12266. C
  12267. C    MINUS   '-'
  12268. C
  12269. C    OPER(9) HOLDS LEGAL ONE CHARACTER OPERATORS LIKE '+' AND '*'.
  12270. C
  12271. C    PLUS    '+'
  12272. C
  12273. C    QUOTE   "'"
  12274. C
  12275. C    RB      HOLDS NEGATIVE POWERS OF 10.(BASE 10)
  12276. C
  12277. C    REAL    PICKS UP REAL*8 CONSTANTS.
  12278. C
  12279. C    RETCD   RETURN CODE:
  12280. C              1 IF OPERAND (VALUE IN RETVAL(100))
  12281. C              2 IF OPERATOR (VALUE IN RETTYP)
  12282. C              3 NO MORE ELEMENTS.
  12283. C              4 IF ERROR.
  12284. C
  12285. C    RETCD2  RETURN CODE WHEN CALLING GETNNB.
  12286. C
  12287. C    RETPT   INDEXES DIGITS PICKED UP FOR A CONSTANT.
  12288. C
  12289. C    RETTYP  THE TYPE CODE OF THE RETURNED ELEMENT.
  12290. C
  12291. C    TYPE    TYPE CODE FOR EACH VARIABLE.
  12292. C
  12293. C    VBLS    HOLDS VALUE OF VARIABLES.
  12294. C
  12295. C    VLEN    GIVES LENGTH IN BYTES FOR EACH DATA TYPE.
  12296. C
  12297. C LASTOP MUST BE SET TO ZERO AT START OF EXPRESSION
  12298. C
  12299. C
  12300.     REAL*8 REAL,RB,ACX,XAC
  12301.     INTEGER*4 INT
  12302.     EXTERNAL INDX,DFLOAT
  12303.     REAL*8 DFLOAT
  12304.     InTeGer*4 INDXX
  12305.     InTeGer*4 LEVEL,NONBLK,LEND
  12306.     InTeGer*4 LASTOP
  12307.     InTeGer*4 VIEWSW,BASED,VLEN(9),DEFBAS
  12308.     InTeGer*4 TYPE(1,1)
  12309.     InTeGer*4 RETCD,RETCD2,RETTYP,EXCODE
  12310.     InTeGer*4 B10,B16,RETPT,BASE
  12311.     InTeGer*4 FCNT,AHOLD
  12312.     InTeGer*4 I,J,K,L,IALPHA,IHOLD,IPT,IPT2,I1,I2
  12313. C
  12314.     CHARACTER*1 CHAR1,DOT,ARROW,QUOTE,STAR,MINUS,PLUS
  12315.     CHARACTER*1 RETVAL(20)
  12316. C    REAL*8 RVLF
  12317. C    EQUIVALENCE (FVLF,RETVAL(1))
  12318.     CHARACTER*1 FUNCT(10,40)
  12319.     InTeGer*4   FUNVAL(2,40)
  12320.     CHARACTER*1 AVBLS(20,27)
  12321.     EQUIVALENCE(XAC,AVBLS(1,27))
  12322.     CHARACTER*1 VBLS(8,1,1)
  12323.     CHARACTER*1 OPER(9),DIGITS(16,3)
  12324.     CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  12325.     CHARACTER*1 FOUR(4),EIGHT(8)
  12326. C
  12327.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  12328.     COMMON /DIGV/ DIGITS
  12329.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  12330.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  12331. C ***<<< KLSTO COMMON START >>>***
  12332.     InTeGer*4 DLFG
  12333. C    COMMON/DLFG/DLFG
  12334.     InTeGer*4 KDRW,KDCL
  12335. C    COMMON/DOT/KDRW,KDCL
  12336.     InTeGer*4 DTRENA
  12337. C    COMMON/DTRCMN/DTRENA
  12338.     REAL*8 EP,PV,FV
  12339.     DIMENSION EP(20)
  12340.     INTEGER*4 KIRR
  12341. C    COMMON/ERNPER/EP,PV,FV,KIRR
  12342. c    InTeGer*4 LASTOP
  12343. C    COMMON/ERROR/LASTOP
  12344.     CHARACTER*1 FMTDAT(9,76)
  12345. C    COMMON/FMTBFR/FMTDAT
  12346.     CHARACTER*1 EDNAM(16)
  12347. C    COMMON/EDNAM/EDNAM
  12348.     InTeGer*4 MFID(2),MFMOD(2)
  12349. C    COMMON/FRM/MFID,MFMOD
  12350.     InTeGer*4 JMVFG,JMVOLD
  12351. C    COMMON/FUBAR/JMVFG,JMVOLD
  12352.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  12353.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  12354. C ***<<< KLSTO COMMON END >>>***
  12355. CCC    COMMON /ERROR/ LASTOP
  12356. C
  12357.     EQUIVALENCE (REAL,EIGHT),(FOUR,INT)
  12358. C
  12359.     DATA DOT/'.'/,ARROW/'^'/,QUOTE/''''/,STAR/'*'/
  12360.     DATA MINUS/'-'/,PLUS/'+'/
  12361.     DATA OPER/'(','-','!','*','/','+','-',')','='/
  12362. C
  12363. C  NUMBER OF FUNCTIONS
  12364.     DATA FCNT/30/
  12365. C
  12366.     DATA FUNCT/'A','B','S',' ',' ',' ',' ',' ',' ', ' ',
  12367.      1             'D','A','B','S',' ',' ',' ',' ',' ',' ',
  12368.      2             'I','A','B','S',' ',' ',' ',' ',' ',' ',
  12369.      3             'F','L','O','A','T',5*' ','I','F','I','X',6*' ',
  12370.      5             'A','I','N','T',6*' ','I','N','T',7*' ',
  12371.      7             'I','D','I','N','T',5*' ','E','X','P',7*' ',
  12372.      9             'D','E','X','P',6*' ','A','L','O','G','1','0',4*' ',
  12373.      2             'D','L','O','G','1','0',4*' ','A','L','O','G',6*' ',
  12374.      4             'D','L','O','G',6*' ','S','Q','R','T',6*' ',
  12375.      6             'D','S','Q','R','T',5*' ','S','I','N',7*' ',
  12376.      8             'D','S','I','N',6*' ','C','O','S',7*' ',
  12377.      1             'D','C','O','S',6*' ','T','A','N','H',6*' ',
  12378.      2             'D','T','A','N','H',5*' ','A','T','A','N',6*' ',
  12379.      3             'D','A','T','A','N',5*' ',
  12380.      1             'A','S','I','N',6*' ','D','A','S','I','N',5*' ',
  12381.      2             'A','C','O','S',6*' ','D','A','C','O','S',5*' ',
  12382.      3             'T','A','N',' ',6*' ','D','T','A','N',106*' '/
  12383.     DATA EXCODE/112/
  12384.        DATA FUNVAL/3,31,4,31,4,32,5,33,4,34,4,35,3,36,5,36,3,37,4,37,
  12385.      1 6,39,6,39,4,38,4,38,4,40,5,40,3,41,4,41,3,42,4,42,4,43,5,43,
  12386.      2       4,44,5,44,4,45,5,45,4,46,5,46,3,47,4,47,20*0/
  12387. C
  12388. 10    CONTINUE
  12389.     CALL GETNNB(IPT,RETCD2)
  12390.     IF (RETCD2.EQ.1) GOTO 50
  12391. C
  12392. C  NO MORE ELEMENTS
  12393.     LASTOP=0
  12394.     RETCD=3
  12395.     RETURN
  12396. C
  12397. C
  12398. C  INITIALIZE VARIABLES
  12399. 50    CONTINUE
  12400.     B10=0
  12401.     B16=0
  12402.     RETTYP=0
  12403.     RETPT=0
  12404.     REAL=0.D0
  12405.     RETCD=1
  12406.     DEFBAS=BASED
  12407. C    RVLF=0.0D0
  12408. C COMMENT OUT DO LOOP OVER 20 BYTES FOR SPEED.
  12409. C (INSTEAD JUST ZERO 8 BYTES WE WILL LIKELY USE)
  12410.     DO 60 I=1,8
  12411. C    DO 60 I=1,20
  12412. 60    RETVAL(I)=0
  12413. C
  12414. 70    CHAR1=LINE(IPT)
  12415.     NONBLK=IPT
  12416. C
  12417. C
  12418. C  SEE IF ALPHABETIC OR %
  12419. C SHORTCUT IF IT'S A CELL NAME .. GO JUST EVALUATE IT.
  12420. C ALSO WORKS FOR ENCODED FUNCT NAMES.
  12421.     IF(ICHAR(CHAR1).GE.255)GOTO 12000
  12422. C SEPARATE OUT FUNCTION CALLS FOR FASTER EXECUTION...SKIP TRYING FUNCT. NAME
  12423. C FIRST AS VARIABLE NAME (WHICH CAN TAKE LONG TIME TO CONVERT BEFORE WE DISCOVER
  12424. C IT ISN'T NEEDED...)
  12425. C
  12426.     IF(ICHAR(CHAR1).GE.230)GOTO 13201
  12427. C ADD COUPLE MORE SHORTCUTS... DON'T JUST LOOP TO SEE IF WE HAVE
  12428. C AN ALPHA CHARACTER...
  12429.     IF(CHAR1.NE.ALPHA(27))GOTO 78
  12430.     I=27
  12431.     GOTO 10000
  12432. 78    CONTINUE
  12433.     IF(CHAR1.LT.'A'.OR.CHAR1.GT.'Z')GOTO 79
  12434. C TRY TO AVOID LOTS OF EXTRA FUNCTION CALLS...
  12435. C COMPARE CHARS AS CHARACTER VALUES... SHOULD STILL BE OK.
  12436. CCC    IF(ICHAR(CHAR1).LT.ICHAR(ALPHA(1))
  12437. CCC     1  .OR.ICHAR(CHAR1).GT.ICHAR(ALPHA(26)))GOTO 79
  12438. C USE FACT THAT ASCII CHARACTER CODES ARE IN A CONTINUOUS RANGE
  12439. CCC    I=ICHAR(CHAR1)-ICHAR(ALPHA(1))
  12440.     I=ICHAR(CHAR1)-65
  12441. C 65 IS ASCII VALUE FOR 'A' CHARACTER.
  12442. C (HARDCODE FOR SPEED...)
  12443.     GOTO 10000
  12444. 79    CONTINUE
  12445. C DELETE 3 LINES FOLLOWING:
  12446. C    DO 80 I=1,27
  12447. C    IF (CHAR1.EQ.ALPHA(I)) GOTO 10000
  12448. C80    CONTINUE
  12449. C
  12450. C
  12451. C  NOT ALPHA SO SEE IF AN OPERATOR
  12452.     DO 100 I=1,9
  12453.     IF (CHAR1.EQ.OPER(I)) GOTO 20000
  12454. 100    CONTINUE
  12455. C
  12456. C
  12457. C SEE IF AN OPERAND
  12458. C *** EVIDENTLY SHORT LOOP RUNS AS FAST AS A COUPLE DECISIONS AND SOME
  12459. C MATH; LEAVE IN.
  12460. 140    DO 150 I=1,16
  12461.     IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
  12462. 150    CONTINUE
  12463. C
  12464. C
  12465. C
  12466.     IF (CHAR1.EQ.DOT) GOTO 40000
  12467. C
  12468. C
  12469. C
  12470.     IF (CHAR1.EQ.ARROW) GOTO 300
  12471. C
  12472. C
  12473. C
  12474.     IF (CHAR1.EQ.QUOTE) GOTO 200
  12475. C
  12476. C
  12477. C  ADDITIONAL CONSTANT OPERATOR WOULD GO HERE
  12478. C
  12479. C
  12480. C *** ERROR *** ILLEGAL CHARACTER ENCOUNTERED
  12481. 190    CALL ERRMSG (20)
  12482.     GOTO 99000
  12483. C
  12484. C
  12485. C
  12486. C
  12487. C **************************************
  12488. C ****** ASCII CONSTANT SPECIFIED ******
  12489. C **************************************
  12490. 200    CONTINUE
  12491.     NONBLK=NONBLK+1
  12492.     RETVAL(1)=ICHAR(LINE(NONBLK))
  12493.     RETTYP=1
  12494.     GOTO 35100
  12495. C
  12496. C
  12497. C
  12498. C
  12499. C **************************************
  12500. C ****** IMMEDIATE BASE SPECIFIED ******
  12501. C **************************************
  12502. 300    CALL GETNNB(IPT,RETCD2)
  12503.     IF (RETCD2.EQ.1) GOTO 320
  12504. C
  12505. C
  12506. C *** ERROR *** ILLEGAL BASE SPECIFICATION
  12507. 310    CALL ERRMSG(19)
  12508.     GOTO 99000
  12509. C
  12510. C
  12511. C  IMMEDIATE BASE SPECIFICATION
  12512. 320    CHAR1=LINE(IPT)
  12513.     NONBLK=IPT
  12514.     IF (CHAR1.EQ.DIGITS(8,3)) GOTO 360
  12515.     IF (CHAR1.NE.DIGITS(1,3)) GOTO 310
  12516. C
  12517. C
  12518. C FIRST DIGIT IS 1 SO IMMEDIATE BASE MIGHT BE 10 OR 16
  12519.     CALL GETNNB (IPT,RETCD2)
  12520.     IF (RETCD2.EQ.2) GOTO 310
  12521.     CHAR1=LINE(IPT)
  12522.     NONBLK=IPT
  12523.     IF (CHAR1.EQ.DIGITS(10,1)) GOTO 365
  12524.     IF (CHAR1.NE.DIGITS(6,1)) GOTO 310
  12525. C
  12526. C
  12527. C IMMEDIATE BASE IS 16
  12528.     DEFBAS=16
  12529.     GOTO 370
  12530. C
  12531. C
  12532. C IMMEDIATE BASE IS 8
  12533. 360    DEFBAS=8
  12534.     GOTO 370
  12535. C
  12536. C
  12537. C IMMEDIATE BASE IS 10
  12538. 365    DEFBAS=10
  12539. C
  12540. C
  12541. C
  12542. 370    CALL GETNNB(IPT,RETCD2)
  12543.     IF (RETCD2.EQ.2) GOTO 310
  12544.     CHAR1=LINE(IPT)
  12545.     NONBLK=IPT
  12546. C
  12547. C
  12548. C GO FIND OUT WHAT NUMBER HAS THAT DEFAULT BASE
  12549.     GOTO 140
  12550. C
  12551. C
  12552. C
  12553. C
  12554. C ****************************************************
  12555. C ****** SEARCH TO SEE IF A UNARY FUNCTION NAME ******
  12556. C ****************************************************
  12557. 10000    CONTINUE
  12558.     IALPHA=I
  12559.     IHOLD=NONBLK
  12560. C
  12561. C
  12562. C SCAN EACH OF THE FUNCTION NAMES.
  12563.     DO 10060 I=1,FCNT
  12564. C
  12565. C K HOLDS NUMBER OF NON-BLANK CHARACTERS IN THE FUNCTION NAME.
  12566.     K=FUNVAL(1,I)
  12567.     IPT2=IHOLD
  12568.     NONBLK=IHOLD
  12569.     IF (K.EQ.0) GOTO 10060
  12570. C
  12571. C
  12572. C SCAN EACH LETTER OF THE FUNCTION'S NAME
  12573.     DO 10050 J=1,K
  12574.     IF (LINE(IPT2).NE.FUNCT(J,I)) GOTO 10060
  12575.     IF (J.EQ.K) GOTO 10100
  12576.     CALL GETNNB (IPT2,RETCD2)
  12577.     IF (RETCD2.EQ.2) GOTO 10060
  12578.     NONBLK=IPT2
  12579. 10050    CONTINUE
  12580.     STOP 10050
  12581. C
  12582. 10060    CONTINUE
  12583. 10070    NONBLK=IHOLD
  12584.     GOTO 12000
  12585. C
  12586. C
  12587. C  FUNCTION FOUND (LEAVES NONBLK POINTING AT LAST CHARACTER)
  12588. 10100    CONTINUE
  12589. C
  12590. C
  12591. C
  12592. C
  12593. C **********************************
  12594. C ****** UNARY FUNCTION FOUND ******
  12595. C **********************************
  12596.     RETTYP=ICHAR(CHAR(FUNVAL(2,I)))
  12597.     LASTOP=RETTYP
  12598.     RETCD=2
  12599.     GOTO 99099
  12600. C
  12601. C
  12602. C
  12603. C
  12604. C
  12605. C ********************************
  12606. C ****** VARIABLE SPECIFIED ******
  12607. C ********************************
  12608. 12000    CONTINUE
  12609. C
  12610. C
  12611. C  IALPHA HOLDS INDEX INTO ALPHA OF NAME
  12612. C ******&&&&&& REMOVE BLK OF CODE STARTING HERE...
  12613. C    CALL GETNNB (IPT,RETCD2)
  12614. C    IF (RETCD2.EQ.2) GOTO 12060
  12615. CC
  12616. CC
  12617. CC MAKE SURE NEXT CHARACTER IS NOT ALPHA
  12618. C    DO 12050 I=1,27
  12619. C    IF (LINE(IPT).EQ.ALPHA(I)) GOTO 12200
  12620. C12050    CONTINUE
  12621. C *****&&&&& ...ENDING HERE
  12622. C ADD BELOW...
  12623.     LLB=IPT
  12624.     LRB=LEND
  12625.     CALL VARSCN(LINE,LLB,LRB,LSTCHR,ID1,ID2,IVALID)
  12626. C    IF(IVALID.EQ.0)GOTO 12200
  12627. C    IPT=LSTCHR
  12628. C leave the following "60" in place. It's only roughly right
  12629. C (probably should be more like 30) but will do since funct.
  12630. C names are 3 chars...
  12631.     IF(IVALID.NE.0.AND.ID2.LE.1.AND.ID1.GT.60)GOTO 13201
  12632.     IF(IVALID.NE.0)GOTO 12201
  12633. C NOT VALID VARIABLE. SEE IF A 2 + ARGUMENT FUNCTION...
  12634. C
  12635. C COME HERE DIRECT FOR FUNCTIONS ENCODED...
  12636. 13201    CONTINUE
  12637.     I=IPT+9
  12638.     CALL FNAME(LINE(IPT),I,INDEXF)
  12639.     IF(INDEXF.EQ.6.OR.INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 12202
  12640. C NOW KNOW THERE IS A FUNCTION THERE, SO HANDLE IT.
  12641.     LLAST=LEND-IPT+1
  12642.     I=INDX(LINE(IPT),ICHAR(']'))
  12643.     IF(I.LE.0.OR.I.GT.LLAST)GOTO 12202
  12644.     LRB=I
  12645.     LLB=INDX(LINE(IPT),ICHAR('['))
  12646.     IF(LLB.LE.0.OR.LLB.GT.LLAST)GOTO 12202
  12647.     CALL DOMFCN(LINE(IPT),LLB,LRB,INDEXF,ACX)
  12648.     XAC=ACX
  12649.     TYPE(1,1)=2
  12650.     CALL TYPSET(1,27,TYPE(1,1))
  12651. C    TYPE(27,1)=2
  12652.     ID1=27
  12653.     ID2=1
  12654.     LSTCHR=LRB+IPT
  12655. C GO AND MERGE AS THOUGH WE JUST GOT A VARIABLE % AND HAD TO
  12656. C RETURN ITS VALUE.
  12657.     GOTO 12201
  12658. C IF NOT VALID FUNCTION REPORT AN ERROR.
  12659. 12202    GOTO 12200
  12660. 12201    IPT=LSTCHR
  12661.     IF(LSTCHR.LT.LEND)IPT=IPT-1
  12662.     NONBLK=IPT
  12663. C RESET NONBLK ALST SO WE RESET GETNNB TOO...
  12664. C WAS IPT=LSTCHR+1
  12665. C IPT POINTS AFTER VARIABLE NAME...
  12666. C ENSURE NON ALPHA AFTER VARIABLE NAME
  12667.     CALL GETNNB(IPT,RETCD2)
  12668.     IF(RETCD2.EQ.2) GOTO 12060
  12669. C
  12670. C IF THE NEXT CHARACTER IS AN = SIGN DON'T RETURN VALUE
  12671. C OF VARIABLE, JUST PUT INDEX INTO VBLS INTO LOWER BYTE
  12672. C OF RETVAL.
  12673.     IF (LINE(IPT).EQ.EQ) GOTO 12100
  12674. C
  12675. C
  12676. C ************************************************
  12677. C ****** RETURN VALUE OF VARIABLE SPECIFIED ******
  12678. C ************************************************
  12679. 12060    CALL TYPGET(ID1,ID2,RETTYP)
  12680. C12060    RETTYP=TYPE(ID1,ID2)
  12681. C *****&&&&&
  12682. C MUST CLAMP TYPES SO EXTENDED VARIABLES CAN'T BE MULT PRCN VRBLS.
  12683.     IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12061
  12684.     IF (RETTYP.EQ.5)RETTYP=4
  12685.     IF (RETTYP.EQ.6)RETTYP=8
  12686.     IF (RETTYP.EQ.7)RETTYP=3
  12687. 12061    CONTINUE
  12688.     IF(RETTYP.LE.0)GO TO 12080
  12689.     K=VLEN(RETTYP)
  12690.     DO 12070 I=1,K
  12691.     IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12068
  12692. C TRY AND CALL XVBLGT HERE TO GET VALUE ALL AT ONCE
  12693. C TO AVOID MULTIPLE ARBITRATION...
  12694.     IF(I.EQ.K)CALL XVBLGT(ID1,ID2,RETVAL)
  12695. C    CALL VBLGET(I,ID1,ID2,RETVAL(I))
  12696. C    RETVAL(I)=VBLS(I,ID1,ID2)
  12697.     GOTO 12070
  12698. 12068    RETVAL(I)=AVBLS(I,ID1)
  12699. 12070    CONTINUE
  12700. C
  12701. 12080    LASTOP=RETTYP
  12702.     GOTO 99099
  12703. C
  12704. C
  12705. C
  12706. C *******************************************************
  12707. C ****** VARIABLE SPECIFIED BUT FOLLOWED BY = SIGN ******
  12708. C *******************************************************
  12709. 12100    CONTINUE
  12710. C    RETVAL(1)=IALPHA
  12711. C    RETTYP=TYPE(IALPHA)
  12712.     CALL TYPGET(ID1,ID2,TYPE(1,1))
  12713.     CALL RVBOO(RETVAL,ID1,ID2)
  12714. C RVBOO JUST STUFFS ID1,ID2 INTO RETVAL ARRAY
  12715. C AS 2 INTEGERS.
  12716.     RETTYP=TYPE(1,1)
  12717.     GOTO 12080
  12718. C
  12719. C
  12720. C
  12721. C *** ERROR *** UNIDENTIFIED FUNCTION
  12722. 12200    CALL ERRMSG(18)
  12723.     GOTO 99000
  12724. C
  12725. C
  12726. C
  12727. C
  12728. C
  12729. C **********************
  12730. C ****** OPERATOR ******
  12731. C **********************
  12732. C
  12733. C  I IS INDEX INTO OPER TO TELL WHAT OPERATOR IT IS
  12734. 20000    CONTINUE
  12735.     RETCD=2
  12736.     IF(I.NE.4)GO TO 20050
  12737. C
  12738. C
  12739. C IF AN ASTERISK IS FOUND THE NEXT CHARACTER MUST BE EXAMINED
  12740. C TO SEE IF '**' WAS SPECIFIED FOR EXPONENTIATION.
  12741.     CALL GETNNB (IPT,RETCD2)
  12742.     IF(RETCD2.NE.1)GO TO 99000
  12743.     IF (LINE(IPT).NE.STAR) GOTO 20050
  12744. C
  12745. C
  12746. C '**' SPECIFIED (EXPONENTIATION)
  12747.     RETTYP=EXCODE
  12748.     NONBLK=IPT
  12749.     GO TO 12080
  12750. C
  12751. C
  12752. C
  12753. C  SET DEFAULT RETTYP FOR OPERATORS
  12754. 20050    RETTYP=109+I
  12755. C
  12756. C
  12757. C  CHECK OUT POSSIBLE UNARY OPERATOR "-"
  12758.     IF (RETTYP.NE.111) GOTO 20080
  12759. C
  12760. C
  12761. C IF A MINUS IS ENCOUNTERED AND THERE WAS NO PREVIOUS ELEMENT OR
  12762. C IF PREVIOUS ELEMENT WAS AN OPERATOR OR = SIGN THEN OPERATOR
  12763. C IS UNARY.
  12764.     IF (LASTOP.EQ.0.OR.(LASTOP.GE.110.AND.LASTOP.LE.116).OR.
  12765.      ;      LASTOP.EQ.200) GOTO 20090
  12766. C
  12767. C
  12768. C  BINARY SUBTRACTION OPERATOR
  12769.     RETTYP=116
  12770.     GOTO 12080
  12771. C
  12772. C
  12773. C
  12774. C SEE IF A '+' SIGN
  12775. 20080    IF(RETTYP.NE.115)GO TO 20085
  12776. C
  12777. C
  12778. C DETERMINE IF IT IS A UNARY PLUS
  12779.     IF(LASTOP.NE.0.AND.LASTOP.LE.100)GO TO 20085
  12780. C
  12781. C
  12782. C SEE IF LAST OPERATOR WAS ')'
  12783.     IF(LASTOP.EQ.117)GO TO 20085
  12784. C
  12785. C
  12786. C UNARY '+' FOUND.
  12787.     RETCD=1
  12788.     GO TO 10
  12789. C
  12790. C
  12791. C
  12792. C RESET LASTOP TO 0 IF LEFT PARENTHESIS IS FOUND (CODE 110)
  12793. C IF RETTYP IS FOR =, SET TO PROPER CODE
  12794. 20085    IF(RETTYP.EQ.110)GO TO 20090
  12795.     IF(RETTYP.EQ.118)RETTYP=200
  12796.     GO TO 12080
  12797. C
  12798. C
  12799. C UNARY -
  12800. 20090    CONTINUE
  12801.     GOTO 99097
  12802. C
  12803. C
  12804. C
  12805. C
  12806. C
  12807. C
  12808. C *************************
  12809. C ****** NON-DECIMAL ******
  12810. C *************************
  12811. C
  12812. 30000    RETPT=RETPT+1
  12813.     IF (RETPT.LE.19) GOTO 30020
  12814. C
  12815. C
  12816. C *** ERROR *** MULTIPLE PRECISION IS LIMITED TO 19 DIGITS
  12817. C (ACTUALLY, NO LONGER PRESENT...)
  12818.     CALL ERRMSG(22)
  12819.     GOTO 99000
  12820. C
  12821. C
  12822. C  I HOLDS INDEX INTO DIGITS THAT WAS A MATCH.
  12823. C  SEE IF VALUE OF DIGIT IMPLIES A HIGHER BASE.
  12824. 30020    IF (I.NE.16) GOTO 30030
  12825.     I=0
  12826.     GOTO 30050
  12827. 30030    IF (I.EQ.8.OR.I.EQ.9) B10=1
  12828.     IF(I.GT.9) B16=1
  12829. 30050    RETVAL(RETPT)=CHAR(I)
  12830. C
  12831. C
  12832. C GET NEXT CHARACTER
  12833.     CALL GETNNB (IPT,RETCD2)
  12834.     IF (RETCD2.NE.1) GOTO 30100
  12835.     NONBLK=IPT
  12836.     CHAR1=LINE(IPT)
  12837.     DO 30070 I=1,16
  12838.     IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
  12839. 30070    CONTINUE
  12840.     IF (CHAR1.EQ.DOT) GOTO 40000
  12841.     NONBLK=NONBLK-1
  12842. 30100    CONTINUE
  12843. C
  12844.     IF (DEFBAS.EQ.16.OR.B16.EQ.1) GOTO 30200
  12845.     IF (DEFBAS.EQ.10.OR.B10.EQ.1) GOTO 30300
  12846. C
  12847. c add code here to check for non -calc mode and goto 40000 if so
  12848. c if defbas.ne.8 and if we're working on a floating number
  12849. C
  12850. C *****************************
  12851. C ****** BASE 8 CONSTANT ******
  12852. C *****************************
  12853.     BASE=8
  12854. C
  12855. C
  12856. C IF MORE THAN 10 DIGITS IT IS MULTIPLE PRECISION
  12857.     IF (RETPT.GT.10) GOTO 30170
  12858.     RETTYP=8
  12859. C
  12860. C
  12861. C  CONVERT TO OCTAL, HEX OR INTEGER
  12862. 30110    INT=0
  12863. 30130    DO 30132 L=1,7
  12864.     IF (ICHAR(RETVAL(L)).NE.0) GOTO 30140
  12865. 30132    CONTINUE
  12866. 30140    DO 30150 I=L,RETPT
  12867.     INT=INT*BASE+ICHAR(RETVAL(I))
  12868.     RETVAL(I)=0
  12869. 30150    CONTINUE
  12870.     RETVAL(20)=0
  12871. 30155    DO 30160 I=1,4
  12872. 30160    RETVAL(I)=FOUR(I)
  12873.     GOTO 35100
  12874. C
  12875. C
  12876. C ************************************************
  12877. C ****** MULTIPLE PRECISION BASE 8 CONSTANT ******
  12878. C ************************************************
  12879. 30170    RETTYP=6
  12880. 30180    CALL FLIP (RETVAL,8,RETPT)
  12881. c was 20 above, not 8 but we shortened stack arrays so shorten this
  12882.     GOTO 35100
  12883. C
  12884. C
  12885. C
  12886. C *********************
  12887. C ****** BASE 16 ******
  12888. C *********************
  12889. 30200    BASE=16
  12890. C
  12891. C
  12892. C IF MORE THAN 7 DIGITS IT IS MULTIPLE PRECISION.
  12893.     IF (RETPT.GT.7) GOTO 30270
  12894. C
  12895. C
  12896. C
  12897. C  HEXADECIMAL
  12898.     RETTYP=3
  12899.     GOTO 30110
  12900. C
  12901. C
  12902. C
  12903. C
  12904. C ****************************************
  12905. C ****** MULTIPLE PRECISION BASE 16 ******
  12906. C ****************************************
  12907. 30270    RETTYP=7
  12908.     GOTO 30180
  12909. C
  12910. C
  12911. C *********************
  12912. C ****** BASE 10 ******
  12913. C *********************
  12914. 30300    BASE=10
  12915. C
  12916. C
  12917. C IF MORE THAN 9 DIGITS IT IS MULTIPLE PRECISION.
  12918.     IF (RETPT.GT.9) GOTO 30370
  12919. C
  12920. C
  12921. C  INTEGER
  12922.     RETTYP=4
  12923.     GOTO 30110
  12924. C
  12925. C
  12926. C ****************************************
  12927. C ****** MULTIPLE PRECISION BASE 10 ******
  12928. C ****************************************
  12929. 30370    RETTYP=5
  12930.     GOTO 30180
  12931. C
  12932. C
  12933. C
  12934. C
  12935. C
  12936. C SET LASTOP AND EXIT
  12937. 35100    LASTOP=RETTYP
  12938.     GOTO 99099
  12939. C
  12940. C
  12941. C *****************************
  12942. C ****** REAL OR DECIMAL ******
  12943. C *****************************
  12944. 40000    IF (B16.NE.1) GOTO 40020
  12945. C
  12946. C
  12947. C *** ERROR ***  '.' MAY ONLY BE USED WITH BASE 10
  12948.     CALL ERRMSG(21)
  12949.     GOTO 99000
  12950. C
  12951. C
  12952. C
  12953. 40020    IF (RETPT.EQ.0) GOTO 40200
  12954. C
  12955. C
  12956. C IGNORE LEADING ZEROES
  12957.     DO 40022 L=1,19
  12958.     IF (ICHAR(RETVAL(L)).NE.0) GOTO 40030
  12959. 40022    CONTINUE
  12960. C
  12961. C IF ALL ZEROES THE LAST ONE COUNTS!
  12962.     L=19
  12963. C
  12964. C
  12965. C CONVERT TO A REAL*8 NUMBER
  12966. 40030    CONTINUE
  12967.     REAL=0.D0
  12968.     DO 40060 I=L,RETPT
  12969.     REAL=REAL*10.D0+ICHAR(RETVAL(I))
  12970.     RETVAL(I)=0
  12971. 40060    CONTINUE
  12972. C
  12973. C
  12974. C  PICK UP FRACTIONAL PART OF REAL (DECIMAL)
  12975. 40200    CONTINUE
  12976.     RB=1.0D0
  12977.     RETTYP=2
  12978. 40205    CALL GETNNB (IPT,RETCD2)
  12979.     IF (RETCD2.EQ.1) GOTO 40300
  12980. C
  12981. C IF NO MORE, YOU GOT IT ALL SO GO PLACE VALUE IN RETVAL.
  12982.     GOTO 40537
  12983. C
  12984. C
  12985. C
  12986. 40300    NONBLK=IPT
  12987.     CHAR1=LINE(IPT)
  12988.     DO 40320 I=1,10
  12989.     IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40330
  12990. 40320    CONTINUE
  12991.     GOTO 40350
  12992. 40330    IF (I.EQ.10) I=0
  12993.     RB=0.1D0*RB
  12994.     REAL=REAL+DFLOAT(I)*RB
  12995.     GOTO 40205
  12996. C
  12997. C
  12998. C CHECK TO SEE IF E OR D EXPONENT SPECIFICATION IS USED.
  12999. 40350    IF (CHAR1.EQ.DIGITS(13,3).OR.CHAR1.EQ.DIGITS(14,3)) GOTO 40360
  13000.     NONBLK=NONBLK-1
  13001.     GO TO 40537
  13002. C
  13003. C
  13004. C *********************************************
  13005. C ****** E AND D EXPONENT SPECIFICATIONS ******
  13006. C *********************************************
  13007. 40360    CONTINUE
  13008.     CALL GETNNB(IPT,RETCD2)
  13009.     IF (RETCD2.EQ.1) GOTO 40370
  13010. C
  13011. C
  13012. C *** ERROR *** ILLEGAL REAL EXPONENT FIELD SPECIFIED
  13013. 40365    CALL ERRMSG (24)
  13014.     GOTO 99000
  13015. C
  13016. C
  13017. 40370    CHAR1=LINE(IPT)
  13018.     IF (CHAR1.EQ.MINUS) GOTO 40380
  13019.     RB=10.D0
  13020.     IF (CHAR1.NE.PLUS) GOTO 40400
  13021.     GOTO 40390
  13022. 40380    RB=0.1D0
  13023. C
  13024. C
  13025. C
  13026. 40390    NONBLK=IPT
  13027.     CALL GETNNB (IPT,RETCD2)
  13028. 40400    IF (RETCD2.GE.2) GOTO 40365
  13029.     NONBLK=IPT
  13030.     CHAR1=LINE(IPT)
  13031.     DO 40450 I=1,10
  13032.     IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40480
  13033. 40450    CONTINUE
  13034.     GOTO 40365
  13035. 40480    IF (I.EQ.10) I=0
  13036. C
  13037. C
  13038. C I1 HOLDS 1ST DIGIT OF EXPONENT SPECIFICATION
  13039.     I1=I
  13040.     CALL GETNNB (IPT,RETCD2)
  13041.     IF (RETCD2.GE.2) GOTO 40550
  13042.     CHAR1=LINE(IPT)
  13043.     NONBLK=IPT
  13044.     DO 40500 I=1,10
  13045.     IF(CHAR1.EQ.DIGITS(I,1)) GO TO 40520
  13046. 40500    CONTINUE
  13047.     NONBLK=NONBLK-1
  13048.     GOTO 40550
  13049. C
  13050. C
  13051. C I2 HOLDS SECOND DIGIT OF EXPONENT SPECIFICATION.
  13052. 40520    IF (I.EQ.10) I=0
  13053.     I2=I
  13054. C
  13055. C
  13056. 40530    RETTYP=9
  13057.     REAL=REAL*RB**(I1*10+I2)
  13058. C
  13059. C
  13060. C
  13061. C ***************************************************
  13062. C ****** COPY REAL*8 INTO RETURN VECTOR RETVAL ******
  13063. C ***************************************************
  13064. 40537    DO 40540 I=1,8
  13065. 40540    RETVAL(I)=EIGHT(I)
  13066.     GOTO 35100
  13067. C
  13068. C
  13069. C
  13070. 40550    I2=I1
  13071.     I1=0
  13072.     GOTO 40530
  13073. C
  13074. C
  13075. C
  13076. C ********************************
  13077. C ******* ERROR PROCESSING *******
  13078. C ********************************
  13079. 99000    CONTINUE
  13080.     IV=LEND-NONBLK+1
  13081.     CALL VWRT(LINE(NONBLK),IV)
  13082. C    WRITE (0,99010) (LINE(I),I=NONBLK,LEND)
  13083. C99010    FORMAT (1X,80(A1,\))
  13084.     RETCD=4
  13085. 99097    LASTOP=0
  13086. 99099    RETURN
  13087.     END
  13088. c -h- pget.for    Tue Sep  2 10:58:55 1986    
  13089.     SUBROUTINE PGET(CMDLIN,ICODE,IRTN)
  13090.     Include AParms.inc
  13091. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  13092. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  13093. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  13094. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  13095. C FROM THE DISK BASED FILE HERE.
  13096.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  13097.     INTEGER*4 VNLT
  13098.         Integer*4 IDRO,IDCL
  13099.     CHARACTER*1 LET1,LET2,FORM2(128),FORM3(110),NMSH(80)
  13100.         Character*127 Form2c
  13101.         Equivalence(Form2(1),Form2c)
  13102.         REAL*8 R8S
  13103.     Integer*4 i4s
  13104.     equivalence(r8s,form3(1))
  13105.     equivalence(i4s,form3(1))
  13106.         INTEGER*4 IBIN
  13107.     COMMON/NMSH/NMSH
  13108.     REAL*8 XVBLS(1,1)
  13109.     INTEGER KPYBAK
  13110. C ***<<<< RDD COMMON START >>>***
  13111.     InTeGer*4 RRWACT,RCLACT
  13112. C    COMMON/RCLACT/RRWACT,RCLACT
  13113.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  13114.      1  IDOL7,IDOL8
  13115. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  13116. C     1  IDOL7,IDOL8
  13117.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  13118. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  13119.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  13120. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  13121. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  13122. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  13123.     InTeGer*4 KLVL
  13124. C    COMMON/KLVL/KLVL
  13125.     InTeGer*4 IOLVL,IGOLD
  13126. C    COMMON/IOLVL/IOLVL
  13127. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  13128. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  13129.     integer*4 idsptp,idol9,k3dfg,kcdelt,krdelt,kpag
  13130.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  13131.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  13132.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,Idsptp,idol9,
  13133.      3  k3dfg,kcdelt,krdelt,kpag
  13134. C ***<<< RDD COMMON END >>>***
  13135. CCC    InTeGer*4 IOLVL
  13136.     INTEGER*4 JVBLS(2,1,1)
  13137. CCC    COMMON/IOLVL/IOLVL
  13138. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  13139. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  13140.     DIMENSION FORM(128),FVLD(1,1)
  13141.     CHARACTER*1 FVWRK,FVWRK2
  13142. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  13143. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  13144. C SO INITIALLY IGNORE.
  13145. C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
  13146. C
  13147. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  13148.  
  13149. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  13150.     CHARACTER*1 LETA
  13151. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  13152. CCC    InTeGer*4 LLCMD,LLDSP
  13153. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  13154.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  13155.     COMMON/D2R/NRDSP,NCDSP
  13156.     InTeGer*4 TYPE(1,1),VLEN(9)
  13157.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  13158.     REAL*8 XAC,ZAC
  13159.     EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
  13160.     REAL*8 XXAC,XYAC
  13161.     EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
  13162. C ***<<< XVXTCD COMMON START >>>***
  13163.     CHARACTER*1 OARRY(100)
  13164.     InTeGer*4 OSWIT,OCNTR
  13165. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  13166. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  13167.     InTeGer*4 IPS1,IPS2,MODFLG
  13168. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  13169.        InTeGer*4 XTCFG,IPSET,XTNCNT
  13170.        CHARACTER*1 XTNCMD(80)
  13171. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  13172. C VARY FLAG ITERATION COUNT
  13173.     INTEGER KALKIT
  13174. C    COMMON/VARYIT/KALKIT
  13175.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  13176.     InTeGer*4 RCMODE,IRCE1,IRCE2
  13177. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  13178. C     1  IRCE2
  13179. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  13180. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  13181. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  13182. C RCFGX ON.
  13183. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  13184. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  13185. C  AND VM INHIBITS. (SETS TO 1).
  13186.     INTEGER*4 FH
  13187. C FILE HANDLE FOR CONSOLE I/O (RAW)
  13188. C    COMMON/CONSFH/FH
  13189.     CHARACTER*1 ARGSTR(52,4)
  13190. C    COMMON/ARGSTR/ARGSTR
  13191.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  13192.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  13193.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  13194.      3  IRCE2,FH,ARGSTR
  13195. C ***<<< XVXTCD COMMON END >>>***
  13196. CCC    CHARACTER*1 ARGSTR(52,4)
  13197. CCC    COMMON/ARGSTR/ARGSTR
  13198. C    EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
  13199. C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
  13200. C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
  13201. C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
  13202. C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
  13203. C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
  13204.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  13205.     INTEGER*4 IIRO,IICO,INUMEM
  13206. C NEED SOME BIG VARIABLES FOR SAVING THE MAPPINGS
  13207.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  13208.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  13209. CCC    COMMON/KLVL/KLVL
  13210.     CHARACTER*1 DEFVB(12)
  13211.     COMMON/DEFVBX/DEFVB
  13212. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  13213. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  13214. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  13215. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  13216. C  AND VM INHIBITS. (SETS TO 1).
  13217. C
  13218. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  13219. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  13220. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  13221. C DISPLAY ACTUALLY USED FOR SCREEN.
  13222.     InTeGer*4 CWIDS(20)
  13223. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  13224. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  13225. C AS 20 NOT 75.
  13226.     REAL*8 DVS(20,75)
  13227.     INTEGER*4 LDVS(2,20,75)
  13228.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  13229.     CHARACTER*76 CFORM
  13230.     EQUIVALENCE(CFORM(1:1),FORM(1))
  13231.     COMMON /FVLDC/FVLD
  13232. C    CHARACTER*1 DFMTS(10,20,75)
  13233. C 10 CHARACTERS PER ENTRY.
  13234.     COMMON/DSPCMN/DVS,CWIDS
  13235. C ***<<< NULETC COMMON START >>>***
  13236.     InTeGer*4 ICREF,IRREF
  13237. C    COMMON/MIRROR/ICREF,IRREF
  13238.     InTeGer*4 MODPUB,LIMODE
  13239. C    COMMON/MODPUB/MODPUB,LIMODE
  13240.     InTeGer*4 KLKC,KLKR
  13241.     REAL*8 AACP,AACQ
  13242. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  13243.     InTeGer*4 NCEL,NXINI
  13244. C    COMMON/NCEL/NCEL,NXINI
  13245.     CHARACTER*1 NAMARY(20,MRows)
  13246. C    COMMON/NMNMNM/NAMARY
  13247.     InTeGer*4 NULAST,LFVD
  13248. C    COMMON/NULXXX/NULAST,LFVD
  13249.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  13250.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  13251. C ***<<< NULETC COMMON END >>>***
  13252.     Character*1 Letr
  13253. CCC    InTeGer*4 ICREF,IRREF
  13254. CCC    COMMON/MIRROR/ICREF,IRREF
  13255. C ENCODE ICREF, IRREF AND CWIDS PAST TITLE IN FIRST LINE
  13256. C (THAT WAY, NOTHING BREAKS IN OTHER PGMS THAT USE THIS)
  13257. C
  13258. C PUT NUMBERS OUT TO FILE
  13259. C USES RELATIVE FORMS TO CURRENT POS.
  13260. C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET.
  13261. C ONLY WRITES PHYSICALLY PRESENT DATA.
  13262. C P/D RRR,CCC,FORMULA,VALID,FORMAT
  13263. C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS.
  13264.     ICODE=1
  13265.     CLOSE(4)
  13266. 7954    CALL UVT100(1,LLCMD,1)
  13267.     CALL UVT100(12,2,0)
  13268. C ASK FOR FILE NAME
  13269.     CALL VWRT('Enter Filename:',15)
  13270.     III=IOLVL
  13271. C    IF(III.EQ.5)III=0
  13272.     if(iii.ne.11)READ(III,7953,END=510,ERR=510)FORM2
  13273.     if(iii.eq.11)call vget(form2,128)
  13274. c7952    FORMAT(' Enter filename>\')
  13275. 7953    FORMAT(128A1)
  13276.     DO 6940 II=1,128
  13277.     ILN=129-II
  13278.     IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
  13279.     FORM2(ILN)=0
  13280. 6940    CONTINUE
  13281. 6941    CONTINUE
  13282. C ILN IS LENGTH OFLINE NOW.
  13283.     ILN=MIN0(ILN,127)
  13284.     FORM2(ILN+1)=0
  13285.         IBIN=0
  13286.         IF(CMDLIN(2).EQ.'B'.OR.CMDLIN(2).EQ.'b')IBIN=1
  13287.     IF(IBIN.EQ.0)CALL WASSIG(4,FORM2)
  13288. C block=-1 is Absoft-specific Amiga hack to get record lengths encoded
  13289. C to allow variable length records to make sense.
  13290.         IF(IBIN.EQ.1)OPEN(UNIT=4,FILE=FORM2c,FORM='UNFORMATTED',
  13291.      1  ACCESS='SEQUENTIAL',STATUS='NEW',BLOCK=-1)
  13292. C NOW ENCODE COL WIDTHS AND ICREF/IRREF
  13293. C SO SAVE/RESTORE OF EXTENDED SHEETS DOESN'T GET
  13294. C MESSED UP.
  13295.     If(Ibin.eq.0)
  13296.      1  WRITE(CFORM(1:76),8850,ERR=8851)ICREF,IRREF,(CWIDS(III),
  13297.      1  III=1,20),DRWV,DCLV
  13298. 8850    FORMAT(24I3)
  13299.     DO 8855 III=1,80
  13300.     II=ICHAR(NMSH(III))
  13301.     IF(II.LT.32)II=32
  13302. 8855    NMSH(III)=CHAR(II)
  13303. 8851    CONTINUE
  13304.     IF(IBIN.EQ.0)WRITE(4,6951)NMSH,(FORM(II),II=1,76)
  13305.         IF(IBIN.EQ.1)WRITE(4,err=448)NMSH,ICREF,IRREF,
  13306.      1  (CWIDS(III),III=1,20),DRWV,DCLV
  13307. 6951    FORMAT(80A1,76A1)
  13308. C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
  13309.     CALL UVT100(1,LLCMD,1)
  13310.     CALL UVT100(12,2,0)
  13311.         MDXM=12000
  13312.         LDXM=12000
  13313.         IF(IBIN.EQ.1)GOTO 448
  13314.     CALL VWRT('Enter max. displ down to save or 0 for all>',43)
  13315.     III=IOLVL
  13316. C    IF(III.EQ.5)III=0
  13317.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)LDXM
  13318.     if(iii.ne.11)call vgeti(ldxm)
  13319. 6950    FORMAT(80A1)
  13320. 7978    FORMAT(I7)
  13321.     CALL UVT100(1,LLCMD,1)
  13322.     CALL UVT100(12,2,0)
  13323.     CALL VWRT('Enter max. displcmt right to save or 0 for all>',47)
  13324.     III=IOLVL
  13325. C    IF(III.EQ.5)III=0
  13326.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)MDXM
  13327.     if(iii.ne.11)call vgeti(mdxm)
  13328.     IF(MDXM.LE.0)MDXM=12000
  13329.     IF(LDXM.LE.0)LDXM=12000
  13330. 448     CONTINUE
  13331. C 12000 IS "AN ARBITRARILY LARGE NUMBER TO ASSURE THAT ALL VALID
  13332. C RANGES ARE SAVED". IT MUST BE SMALL ENOUGH TO ASSURE WE DON'T OVERFLOW AN
  13333. C INTEGER THOUGH.
  13334.     IF(CMDLIN(2).NE.'P'.and.CMDLIN(2).GT.' '.AND.IBIN.EQ.0)
  13335.      1   GOTO 7950
  13336. C TREAT "P" BY ITSELF AS A SAVE PP TYPE COMMAND (PUT PHYS)
  13337. C Could speed this by saving only what's been filled.
  13338. C RCLACT can be up to 301, RRWACT can be up to MCols
  13339. C since current cell may be outside this area, use scratch vbls
  13340. C to ensure all's well
  13341.     If(K3dfg.lt.0)Goto 8601
  13342. C write out special "flag" record to preserve 3D mapping
  13343. C information IF mapping is not disabled.
  13344.     Letr='F'
  13345.     if(ibin.eq.1)goto 8602
  13346.     WRITE(4,5403)LETR,k3dfg,KCDelt,KRDelt
  13347.     Goto 8603
  13348. 8602    Continue
  13349.     i4s=KRDelt
  13350.     WRITE(4)LETR,K3Dfg,KCDelt,
  13351.      1  (form3(ivv),ivv=1,110)
  13352. 8603    Continue
  13353. C fill in other rubbish as second part of record.
  13354.     Type(1,1)=2
  13355.     Form2(119)=-3
  13356.     If(Ibin.eq.0)
  13357.      1  WRITE(4,7956)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1)
  13358.     If(Ibin.eq.1)
  13359.      1  WRITE(4)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1)
  13360. C
  13361. 8601    Continue
  13362.     Irrw=max0(PCOL,RCLACT)
  13363.     Ircl=max0(PROW,RRWACT)
  13364. c    DO 7951 ICO=PCOL,301
  13365. c    DO 7951 IRO=PROW,60
  13366.     DO 7951 ICO=PCOL,Irrw
  13367.     DO 7951 IRO=PROW,Ircl
  13368. C GO DOWN AND RIGHT ONLY. ALLOW MIXING THIS WAY.
  13369. C    IRX=(ICO-1)*60+IRO
  13370.     CALL REFLEC(ICO,IRO,IRX)
  13371.     IDRO=IRO-PROW+1
  13372.     IDCL=ICO-PCOL+1
  13373.     IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7951
  13374. C FORM DISPLACEMENT LOCATORS
  13375.     CALL FVLDGT(IRO,ICO,FVLD(1,1))
  13376.     IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7951
  13377.     CALL WRKFIL(IRX,FORM,0)
  13378.     CALL CE2A(FORM,FORM2)
  13379.     IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
  13380.     IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
  13381.     CALL TYPGET(IRO,ICO,TYPE(1,1))
  13382.     IF(CMDLIN(3).NE.'N')GOTO 5402
  13383.     IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5402
  13384. C ALWAYS WRITE TEXT OUT EVEN IF SAVING NUMERICALLY
  13385. C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
  13386. C INTERNAL PROC TO PRINT NUMERIC VALUES AT 6400
  13387.     LETR='P'
  13388.     ASSIGN 5405 TO INUMEM
  13389. C    GOTO 6400
  13390. 6400    CONTINUE
  13391. C ASSUME LETR IS SET TO GOOD PREFIX LETTER ASCII VALUE
  13392.     CALL XVBLGT(IRO,ICO,XVBLS(1,1))
  13393.         IF(IBIN.EQ.1)GOTO 449
  13394.     IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5403)LETR,IDRO,IDCL,
  13395.      1  JVBLS(1,1,1)
  13396. 5403    FORMAT(1A1,I5,',',I5,',',I15)
  13397.     IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5404)LETR,IDRO,IDCL,
  13398.      1  XVBLS(1,1)
  13399.         GOTO 450
  13400. 449     CONTINUE
  13401.         R8S=XVBLS(1,1)
  13402.     WRITE(4,err=450)LETR,IDRO,IDCL,FORM3
  13403. 450     CONTINUE
  13404. 5404    FORMAT(1A1,I5,',',I5,',',D30.19)
  13405.     GOTO INUMEM,(5405,6406)
  13406. 5402    CONTINUE
  13407. C FIND END OF TEXT IN ARRAY
  13408.     IVVV=110
  13409.         If(Ibin.eq.1)goto 4331
  13410. C skip this truncation for binary saves
  13411.     DO 4330 IV=2,110
  13412.     IVVV=113-IV
  13413.     IF(ICHAR(FORM2(IVVV)).GT.32)GOTO 4331
  13414. 4330    CONTINUE
  13415. 4331    CONTINUE
  13416. C SAVE ON PPX IN EFFICIENT FORM.
  13417. C DON'T WRITE OUT TRAILING NULLS.
  13418. C ENSURE FORMAT HAS NO NULLS IN IT.
  13419.     DO 358 IV=120,128
  13420. 358    IF(ICHAR(FORM2(IV)).LT.32)FORM2(IV)=Char(32)
  13421.     IF(CMDLIN(3).EQ.'F')GOTO 6404
  13422. C PPF WILL SAVE FORMULAS ONLY
  13423. C PPA WILL SAVE FORMULAS AND VALUES (AS WILL PPc WHERE c IS
  13424. C ANY CHARACTER EXCEPT N.
  13425.     LETR='p'
  13426. C FLAG NUMERIC SAVE VIA LOWERCASE P HERE
  13427.     ASSIGN 6406 TO INUMEM
  13428. C GO WRITE FIRST LINE NUMERICALLY
  13429.     GOTO 6400
  13430. 6406    CONTINUE
  13431. C NOW HAVE NUMERIC LINE WRITTEN. WRITE THE SECOND LINE OF THE
  13432. C GROUP TO, SO AS NOT TO CONFUSE GRAPHICS PROGRAMS AND THE
  13433. C LIKE.
  13434.     III=JCHAR(FORM2(119))
  13435.     IF(IBIN.EQ.0)WRITE(4,7956)III,(FORM2(IV),IV=120,128),
  13436.      1   TYPE(1,1)
  13437.     IF(IBIN.EQ.1)WRITE(4,err=6404)III,(FORM2(IV),IV=120,128),
  13438.      1   TYPE(1,1)
  13439. 6404    CONTINUE
  13440. C NOW WRITE OUT FORMULA RECORD.
  13441.     If(Ibin.eq.0)WRITE(4,7955)IDRO,IDCL,
  13442.      1   (FORM2(IV),IV=1,IVVV)
  13443.         Letr=char(80)
  13444.         If(Ibin.eq.1)Write(4,err=5405)Letr,idro,idcl,
  13445.      1   (form2(iv),iv=1,ivvv)
  13446. 5405    CONTINUE
  13447. C DUMP TO SERIAL FILE IN OUR OWN FORMAT, BUT ALL IN ASCII.
  13448. 7955    FORMAT('P',I5,',',I5,',',128A1)
  13449. C NOTE LONG RECORDS.
  13450.     III=JCHAR(FORM2(119))
  13451.     If(ibin.eq.0)WRITE(4,7956)III,(FORM2(IV),IV=120,128),
  13452.      1  TYPE(1,1)
  13453.     If(Ibin.eq.1)WRITE(4,err=7951)III,(FORM2(IV),IV=120,128),
  13454.      1  TYPE(1,1)
  13455. 7956    FORMAT(I3,',',9A1,',',I5)
  13456. 7951    CONTINUE
  13457. 2751    CONTINUE
  13458. C
  13459. C NOW SAVE NRDSP AND NCDSP MAPPINGS TOO
  13460. C ONLY SAVE MAPPINGS IF 4TH COMMAND CHARACTER IS "M".
  13461. C ... THEY TAKE A LOT OF ROOM.
  13462.     IF (CMDLIN(4).NE.'M') GOTO 6541
  13463.     DO 6540 IRO=DROW,20
  13464.     DO 6540 ICO=DCOL,75
  13465.     IIRO=64000
  13466.     IICO=IIRO
  13467.     IIRO=IIRO+IRO
  13468.     IICO=IICO+ICO
  13469. C NOTE WE MAKE THESE NUMBERS LARGE SO GRAPHING PROGRAMS WON'T TRY
  13470. C TO READ THEM.
  13471. 6955    FORMAT('M',I5,',',I5,',',2I7)
  13472.         Letr='M'
  13473.         If(Ibin.eq.0)
  13474.      1   WRITE(4,6955,ERR=6541)IIRO,IICO,
  13475.      1   NRDSP(IRO,ICO),NCDSP(IRO,ICO)
  13476.         If(Ibin.eq.1)
  13477.      1   WRITE(4,ERR=6541)Letr,IIRO,IICO,
  13478.      1   NRDSP(IRO,ICO),NCDSP(IRO,ICO)
  13479. C WRITE A SPECIAL RECORD, FLAGGED BY 'M', TO SAVE A MAPPING CELL
  13480. C NEED A 2ND RECORD TOO; JUST SEND LAST ONE AGAIN.
  13481.     If(ibin.eq.0)WRITE(4,7956)III,(FORM2(IV),IV=120,128),
  13482.      1  TYPE(1,1)
  13483.     If(Ibin.eq.1)WRITE(4,err=6541)III,(FORM2(IV),IV=120,128),
  13484.      1  TYPE(1,1)
  13485. 6540    CONTINUE
  13486. 6541    CONTINUE
  13487.     CLOSE(4)
  13488.     GOTO 9990
  13489. 7950    IF(CMDLIN(2).NE.'D')GOTO 9990
  13490.     DO 7957 ICO=DCOL,75
  13491.     DO 7957 IRO=DROW,20
  13492.     IDRO=IRO-DROW+1
  13493.     IDCL=ICO-DCOL+1
  13494.     IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7957
  13495.     NR=NRDSP(IRO,ICO)
  13496.     NC=NCDSP(IRO,ICO)
  13497. C    IRX=(NC-1)*60+NR
  13498.     CALL REFLEC(NC,NR,IRX)
  13499.     CALL FVLDGT(NR,NC,FVLD(1,1))
  13500.     IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7957
  13501.     CALL WRKFIL(IRX,FORM,0)
  13502.     CALL CE2A(FORM,FORM2)
  13503.     IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
  13504.     IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
  13505.     IF(CMDLIN(3).NE.'N')GOTO 5412
  13506. C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
  13507.     IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5412
  13508. C WRITE LABELS EVEN IF NUMERIC SAVE
  13509.     CALL TYPGET(NR,NC,TYPE(1,1))
  13510.     CALL XVBLGT(NR,NC,XVBLS(1,1))
  13511.     IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5413)IDRO,IDCL,JVBLS(1,1,1)
  13512. 5413    FORMAT('P',I5,',',I5,',',I15)
  13513.     IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5414)IDRO,IDCL,XVBLS(1,1)
  13514. 5414    FORMAT('P',I5,',',I5,',',D30.19)
  13515.     GOTO 5415
  13516. 5412    CONTINUE
  13517.     WRITE(4,7958)IDRO,IDCL,(FORM2(IV),IV=1,110)
  13518. 5415    CONTINUE
  13519. 7958    FORMAT('D',I5,',',I5,',',128A1)
  13520.     DO 359 IV=120,128
  13521. 359    IF(FORM2(IV).LT.' ')FORM2(IV)=Char(32)
  13522.     III=JCHAR(FORM2(119))
  13523.     WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
  13524. 7957    CONTINUE
  13525. C ALLOW SAVE AS NEEDED OF MAPPING
  13526.     GOTO 2751
  13527. C    CLOSE(4)
  13528. 9990    RETURN
  13529. 510    CONTINUE
  13530.     IRTN=1
  13531.     CLOSE(IOLVL)
  13532. c    CLOSE(11)
  13533. c    OPEN(11,FILE='CON:0/0/100/100/Analy Command')
  13534.     RETURN
  13535.     END
  13536. c -h- pgget.for    Tue Sep  2 10:58:55 1986    
  13537.     SUBROUTINE PGGET(CMDLIN,ICODE,IRTN)
  13538.     Include AParms.inc
  13539. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  13540. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  13541. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  13542. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  13543. C FROM THE DISK BASED FILE HERE.
  13544.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  13545.     INTEGER*4 VNLT
  13546.     CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
  13547.         Real*8 R8s
  13548.         Integer*4 I4s,I4t
  13549.         Equivalence(R8s,form2(1)),(I4s,form2(1))
  13550.         Equivalence (I4t,form2(3))
  13551.         Character*127 Form2c
  13552.         Equivalence(Form2(1),Form2c)
  13553.     COMMON/NMSH/NMSH
  13554.     REAL*8 XVBLS(1,1)
  13555.     INTEGER KPYBAK
  13556. C ***<<<< RDD COMMON START >>>***
  13557.     InTeGer*4 RRWACT,RCLACT
  13558. C    COMMON/RCLACT/RRWACT,RCLACT
  13559.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  13560.      1  IDOL7,IDOL8
  13561. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  13562. C     1  IDOL7,IDOL8
  13563.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  13564. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  13565.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  13566. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  13567. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  13568. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  13569.     InTeGer*4 KLVL
  13570. C    COMMON/KLVL/KLVL
  13571.     InTeGer*4 IOLVL,IGOLD
  13572. C    COMMON/IOLVL/IOLVL
  13573. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  13574. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  13575.     Integer*4 idsptp,idol9,k3dfg,kcdelt,krdelt,kpag
  13576.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  13577.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  13578.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,Idsptp,Idol9,
  13579.      3  K3dfg,kcdelt,krdelt,kpag
  13580. C ***<<< RDD COMMON END >>>***
  13581. CCC    InTeGer*4 IOLVL
  13582.     INTEGER*4 JVBLS(2,1,1)
  13583.     REAL*8 R8WK
  13584. CCC    COMMON/IOLVL/IOLVL
  13585. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  13586. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  13587.     DIMENSION FORM(128),FVLD(1,1)
  13588.     INTEGER*4 IRRW,ICCL
  13589. C USE BIG NUMBERS SO WE CAN SUBTRACT 64000 AND STILL NOT GET WRAPAROUND.
  13590. C (FOR SAVE/RESTORE OF MAP)
  13591.     CHARACTER*76 CFORM
  13592.     CHARACTER*35 CFORM2
  13593.     EQUIVALENCE(CFORM2(1:1),FORM2(1))
  13594.     EQUIVALENCE(CFORM(1:1),FORM(1))
  13595.     InTeGer*4 NDUM(24)
  13596. C ***<<< NULETC COMMON START >>>***
  13597.     InTeGer*4 ICREF,IRREF
  13598. C    COMMON/MIRROR/ICREF,IRREF
  13599.     InTeGer*4 MODPUB,LIMODE
  13600. C    COMMON/MODPUB/MODPUB,LIMODE
  13601.     InTeGer*4 KLKC,KLKR
  13602.     REAL*8 AACP,AACQ
  13603. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  13604.     InTeGer*4 NCEL,NXINI
  13605. C    COMMON/NCEL/NCEL,NXINI
  13606.     CHARACTER*1 NAMARY(20,MRows)
  13607. C    COMMON/NMNMNM/NAMARY
  13608.     InTeGer*4 NULAST,LFVD
  13609. C    COMMON/NULXXX/NULAST,LFVD
  13610.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  13611.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  13612. C ***<<< NULETC COMMON END >>>***
  13613. CCC    COMMON/MIRROR/ICREF,IRREF
  13614.     CHARACTER*1 FVWRK,FVWRK2
  13615. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  13616. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  13617. C SO INITIALLY IGNORE.
  13618. C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
  13619. C
  13620. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  13621. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  13622. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  13623. CCC    InTeGer*4 LLCMD,LLDSP
  13624. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  13625.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  13626.     EXTERNAL INDX
  13627.     COMMON/D2R/NRDSP,NCDSP
  13628.     InTeGer*4 TYPE(1,1),VLEN(9)
  13629.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  13630.     REAL*8 XAC,ZAC
  13631.     EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
  13632.     REAL*8 XXAC,XYAC
  13633.     EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
  13634. C ***<<< XVXTCD COMMON START >>>***
  13635.     CHARACTER*1 OARRY(100)
  13636.     InTeGer*4 OSWIT,OCNTR
  13637. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  13638. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  13639.     InTeGer*4 IPS1,IPS2,MODFLG
  13640. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  13641.        InTeGer*4 XTCFG,IPSET,XTNCNT
  13642.        CHARACTER*1 XTNCMD(80)
  13643. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  13644. C VARY FLAG ITERATION COUNT
  13645.     INTEGER KALKIT
  13646. C    COMMON/VARYIT/KALKIT
  13647.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  13648.     InTeGer*4 RCMODE,IRCE1,IRCE2
  13649. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  13650. C     1  IRCE2
  13651. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  13652. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  13653. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  13654. C RCFGX ON.
  13655. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  13656. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  13657. C  AND VM INHIBITS. (SETS TO 1).
  13658.     INTEGER*4 FH
  13659. C FILE HANDLE FOR CONSOLE I/O (RAW)
  13660. C    COMMON/CONSFH/FH
  13661.     CHARACTER*1 ARGSTR(52,4)
  13662. C    COMMON/ARGSTR/ARGSTR
  13663.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  13664.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  13665.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  13666.      3  IRCE2,FH,ARGSTR
  13667. C ***<<< XVXTCD COMMON END >>>***
  13668. CCC    CHARACTER*1 ARGSTR(52,4)
  13669. CCC    COMMON/ARGSTR/ARGSTR
  13670. C    EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
  13671. C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
  13672. C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
  13673. C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
  13674. C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
  13675. C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
  13676.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  13677.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  13678.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  13679. CCC    COMMON/KLVL/KLVL
  13680.     CHARACTER*1 DEFVB(12)
  13681.     COMMON/DEFVBX/DEFVB
  13682. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  13683. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  13684. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  13685. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  13686. C  AND VM INHIBITS. (SETS TO 1).
  13687. C
  13688. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  13689. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  13690. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  13691. C DISPLAY ACTUALLY USED FOR SCREEN.
  13692.     InTeGer*4 CWIDS(20)
  13693. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  13694. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  13695. C AS 20 NOT 75.
  13696.     REAL*8 DVS(20,75)
  13697.     INTEGER*4 LDVS(2,20,75)
  13698.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  13699.     COMMON /FVLDC/FVLD
  13700. CCC    InTeGer*4 NCEL,NXINI
  13701. CCC    COMMON/NCEL/NCEL,NXINI
  13702. C    CHARACTER*1 DFMTS(10,20,75)
  13703. C 10 CHARACTERS PER ENTRY.
  13704.     COMMON/DSPCMN/DVS,CWIDS
  13705. C
  13706. c7952    FORMAT(' Enter filename>\')
  13707. 7953    FORMAT(128A1)
  13708. 6950    FORMAT(80A1)
  13709. 7978    FORMAT(I7)
  13710. 7956    FORMAT(I3,1X,9A1,1X,I5)
  13711.     CLOSE(4)
  13712. 7960    CALL UVT100(1,LLCMD,1)
  13713.     CALL UVT100(12,2,0)
  13714. C GET FILE NAME
  13715.     call Vwrt('Enter Filename:',15)
  13716.     III=IOLVL
  13717. C    IF(III.EQ.5)III=0
  13718.     if(iii.ne.11)READ(III,7953,END=510,ERR=510)FORM2
  13719.     if(iii.eq.11)call vget(form2,128)
  13720.     DO 6940 II=1,128
  13721.     ILN=129-II
  13722.     IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
  13723.     FORM2(ILN)=Char(0)
  13724. 6940    CONTINUE
  13725. 6941    CONTINUE
  13726. C ILN IS LENGTH OFLINE NOW.
  13727.     ILN=MIN0(127,ILN)
  13728.     FORM2(ILN+1)=Char(0)
  13729. C SPECIAL "FAST READ" MODE TO SET UP DATA AREAS ON GETTING OLD SHEETS...
  13730.     NXINI=1
  13731.     LDXM=INDX(FORM2,ICHAR('/'))
  13732. C IF FILE IS FILENAME/M WE WON'T DO IT FAST...
  13733.     IF(LDXM.LE.0.OR.LDXM.GE.ILN)GOTO 8400
  13734.     FORM2(LDXM)=Char(0)
  13735. C TERMINATE AFTER THE / AND SET NXINI TO 0 AGAIN
  13736.     NXINI=0
  13737. 8400    CONTINUE
  13738.         Ibin=0
  13739.         If(Cmdlin(2).eq.'B'.OR.cmdlin(2).eq.'b')Ibin=1
  13740.     If(Ibin.eq.0)CALL RASSIG(4,FORM2)
  13741. C BLOCK=-1 IS HACK TO READ ABSOFT UNFORMATTED BIN RECS AS VBL LEN
  13742.         If(Ibin.eq.1)Open(unit=4,file=form2c,form='Unformatted',
  13743.      1  access='SEQUENTIAL',status='OLD',BLOCK=-1)
  13744.         If(Ibin.eq.0)
  13745.      1  READ(4,6951,END=7964,ERR=7964)NMSH,FORM
  13746.         If(Ibin.eq.1)
  13747.      1  READ(4,END=7964,ERR=7107)NMSH,Ndum
  13748. 7107    Continue
  13749. 6951    FORMAT(80A1,76A1,56A1)
  13750. 6952    FORMAT(24I3)
  13751. C TRY TO DECODE ICREF,IRREF, CWIDS, AND DRWV,DCLV
  13752.     If(Ibin.eq.0)READ(CFORM(1:76),6952,ERR=6953)NDUM
  13753. C IF HERE, THE READ WAS OK (APPARENTLY)
  13754. C FILL IN DEFAULTS IF NOTHING BUT ZEROES REALLY WAS SEEN
  13755. C (OR JUST ALL SPACES)
  13756.     ICREF=NDUM(1)
  13757.     IF(ICREF.LE.0.OR.ICREF.GT.MCols)ICREF=10
  13758.     IRREF=NDUM(2)
  13759.     IF(IRREF.LE.0.OR.IRREF.GT.(MRows-1))IRREF=50
  13760. C SET UP CWIDS BUT DEFAULT TO 10 IF NO REAL INFO THERE
  13761.     DO 6954 III=1,20
  13762.     IIVV=NDUM(III+2)
  13763.     IF(IIVV.LT.1.OR.IIVV.GT.100)IIVV=10
  13764.     CWIDS(III)=IIVV
  13765. 6954    CONTINUE
  13766. C RESTORE NUMBER ROWS AND COLS BEING DISPLAYED
  13767. C NOTE WE DO NOT RESTORE THE COMPLETE DISPLAY
  13768. C MAPPING; JUST THE WIDTHS AND NUMBERS OF DISPLAY
  13769. C COLUMNS, AND WE RESTORE THE EXTENDED MAP SO THAT
  13770. C SAVED SHEETS WILL NORMALLY GET BACK THE SAME EXTENDED
  13771. C ADDRESSING THAT HAD BEEN SET UP.
  13772.     DRWV=NDUM(23)
  13773.     IF(DRWV.LT.1.OR.DRWV.GT.20)DRWV=7
  13774.     DCLV=NDUM(24)
  13775.     IF(DCLV.LT.1.OR.DCLV.GT.75)DCLV=20
  13776. 6953    CONTINUE
  13777. C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
  13778.     CALL UVT100(1,LLCMD,1)
  13779.     CALL UVT100(12,2,0)
  13780.         mdxm=12000
  13781.         ldxm=12000
  13782.         mmdxm=1
  13783.         lldxm=1
  13784.         If(ibin.eq.1)Goto 662
  13785.     CALL VWRT('Enter max. displc. down to restore or 0 for all>',48)
  13786.     III=IOLVL
  13787. C    IF(III.EQ.5)III=0
  13788.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)MDXM
  13789.     if(iii.eq.11)call vgeti(mdxm)
  13790.     CALL UVT100(1,LLCMD,1)
  13791.     CALL UVT100(12,2,0)
  13792.     CALL VWRT('Enter max. displc. right to restore or 0 for all>',
  13793.      1  49)
  13794.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)LDXM
  13795.     if(iii.eq.11)call vgeti(ldxm)
  13796.     CALL UVT100(1,LLCMD,1)
  13797.     CALL UVT100(12,2,0)
  13798.     CALL VWRT('Enter min. displ. down (1 or more)>',35)
  13799.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)MMDXM
  13800.     if(iii.eq.11)call vgeti(mmdxm)
  13801.     CALL UVT100(1,LLCMD,1)
  13802.     CALL UVT100(12,2,0)
  13803.     CALL VWRT('Enter min displ. right (1 or more)>',35)
  13804.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)LLDXM
  13805.     if(iii.eq.11)call vgeti(lldxm)
  13806. 662     Continue
  13807.     IF(MDXM.LE.0)MDXM=12000
  13808.     LLDXM=MAX0(1,LLDXM)
  13809.     MMDXM=MAX0(1,MMDXM)
  13810.     IF(LDXM.LE.0)LDXM=12000
  13811.     IF(CMDLIN(4).EQ.'+'.OR.CMDLIN(4).EQ.'-')RCFGX=1
  13812. C ENTER RECALC MANUAL MODE IF ADDING NUMBERS OR SUBT.
  13813. C FROM SAVED SHEET
  13814. C 12000 IS, AS ABOVE, JUST A "BIG" NUMBER.
  13815. 7961    CONTINUE
  13816.         If(Ibin.eq.0)
  13817.      1  READ(4,7962,END=7964,ERR=7964)LET1,IRRW,ICCL,(FORM2(IV),
  13818.      1  IV=1,110)
  13819.         If(Ibin.eq.1)
  13820.      1  READ(4,END=7964,ERR=7108)LET1,IRRW,ICCL,(FORM2(IV),
  13821.      1  IV=1,110)
  13822. 7962    FORMAT(A1,I5,1X,I5,1X,128A1)
  13823. 7108    Continue
  13824.         ivv=110
  13825.         If(Ibin.eq.1)Goto 4496
  13826.     DO 4497 IV=1,110
  13827.     IVV=111-IV
  13828.     IF(FORM2(IVV).GT.' ')GOTO 4496
  13829.     FORM2(IVV)=Char(0)
  13830. 4497    CONTINUE
  13831. 4496    CONTINUE
  13832. C ABOVE LOOP ENSURES THAT EXTRA PARTS OF BUFFER NOT IN SAVE FILE ARE
  13833. C ZEROED ON READIN.
  13834.         If(Ibin.eq.0)
  13835.      1  READ(4,7956,END=7964,ERR=7964)III,(FORM2(IV),IV=120,128),
  13836.      1  KKTYP
  13837.         If(Ibin.eq.1)
  13838.      1  READ(4,END=7964,ERR=7109)III,(FORM2(IV),IV=120,128),
  13839.      1  KKTYP
  13840. 7109    Continue
  13841.     FORM2(119)=Char(III)
  13842.     If(k3dfg.lt.0)goto 8602
  13843. C Handle F records (flags)
  13844.     If(Let1.ne.'F')goto 8602
  13845.     if(ibin.ne.0)goto 8603
  13846.     Read(form2c(1:15),8604,err=7961)I4S
  13847. c    DECODE(15,8604,FORM2(1),ERR=7961)I4S
  13848. 8604    FORMAT(I15)
  13849. 8603    Continue
  13850. C set all values together so if decode error occurs things will
  13851. C remain consistent.
  13852.     krdelt=i4s
  13853.     k3dfg=irrw
  13854.     kcdelt=iccl
  13855. C No further processing of flag records.
  13856.     GoTo 7961
  13857. 8602    Continue
  13858.     IF(LET1.EQ.'M')GOTO 6500
  13859. C M CODE MEANS WE'RE READING THE DISPLAY-TO-PHYSICAL MAP.
  13860. C GO HANDLE IT SPECIALLY, THEN RETURN. FLAGS RECORDS BY
  13861. C ADDING 64000 TO ROW AND COL NUMBERS TO AVOID GETTING
  13862. C GRAPHICS PROGRAMS MESSED UP.
  13863. C  NOTE THAT SAVING THE MAP WAS OPTIONAL AND IS NOT THE
  13864. C DO-NOTHING DEFAULT.
  13865.     IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
  13866.     IF(JCHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
  13867.     IF(IRRW.LE.0.OR.ICCL.LE.0)GOTO 9990
  13868.     IF(IRRW.GT.LDXM.OR.ICCL.GT.MDXM)GOTO 7961
  13869.     IF(IRRW.LT.LLDXM.OR.ICCL.LT.MMDXM) GOTO 7961
  13870. C PRODUCE NEW ADDRESSES IN PHYSICAL SHEET USING SAVED FILE'S ONES
  13871. C AND CURSOR LOCATION (SINCE WE SAVE/RESTORE RELATIVE TO CURSOR).
  13872. C THIS PROVIDES A SHEET PARTIAL SAVE / MERGE CAPABILITY.
  13873.     NR=IRRW+PROW-LLDXM
  13874.     NC=ICCL+PCOL-MMDXM
  13875.     IF(CMDLIN(2).NE.'D'.AND.LET1.NE.68)GOTO 7963
  13876.     IF(CMDLIN(2).EQ.'P'.or.ibin.eq.1)GOTO 7963
  13877. C GET DISPLAY VERSION...
  13878.     LRR=IRRW+DROW-LLDXM
  13879.     LCC=ICCL+DCOL-MMDXM
  13880.     LRR=MAX0(1,LRR)
  13881.     LCC=MAX0(1,LCC)
  13882.     IF(LRR.GT.DRWV.OR.LCC.GT.DCLV)GOTO 7961
  13883.     NR=NRDSP(LRR,LCC)
  13884.     NC=NCDSP(LRR,LCC)
  13885. 7963    CONTINUE
  13886. C LET1='p'WILL COME HERE TOO. HANDLE IT SINCE IT'S NUMERIC STUFF.
  13887. C    IRX=(NC-1)*60+NR
  13888.     CALL REFLEC(NC,NR,IRX)
  13889.     IF(NR.EQ.0.OR.NC.EQ.0)GOTO 7961
  13890.     FORM2(118)=CHAR(15)
  13891.     DO 7113 IVV=1,128
  13892. 7113    FORM(IVV)=FORM2(IVV)
  13893.     INRW=PROW
  13894.     INCL=PCOL
  13895.     JOUTR=1
  13896.     JOUTC=2
  13897. C A1 = OUT LOCATION FOR INPUT CELL NAMES
  13898.     JRTR=1
  13899.     JRTC=1
  13900.     IF(CMDLIN(3).EQ.'R')CALL RELVBL(FORM,FORM2,JOUTR,JOUTC,
  13901.      1  INRW,INCL,JRTR,JRTC)
  13902. C ALLOW RELOCATION ON LOADING SAVED SHEET IF DESIRED.
  13903.     CALL FVLDST(NR,NC,FORM2(119))
  13904. C    FVLD(NR,NC)=FORM2(119)
  13905.     CALL TYPSET(NR,NC,KKTYP)
  13906. C    TYPE(NR,NC)=KKTYP
  13907.     CALL CA2E(FORM2,FORM)
  13908.     IF(LET1.NE.'p')CALL WRKFIL(IRX,FORM,1)
  13909. C    WRITE(7'IRX)FORM2
  13910.     IF(LET1.NE.'p')GOTO 7961
  13911. C HAVE LOWERCASE 'p' NOW AS NUMERIC SAVE FLAG FOR THIS RECORD.
  13912.         if(Ibin.eq.1)xvbls(1,1)=r8s
  13913.         If(Ibin.eq.0)
  13914.      1  READ(CFORM2(1:35),6408,ERR=7961)XVBLS(1,1)
  13915. 6408    FORMAT(BN,D30.19)
  13916.         If(Cmdlin(4).ne.'-'.And.Cmdlin(4).ne.'+')Goto 982
  13917.     CALL XVBLGT(NR,NC,R8WK)
  13918.     IF(CMDLIN(4).EQ.'+')XVBLS(1,1)=XVBLS(1,1)+R8WK
  13919.     IF(CMDLIN(4).EQ.'-')XVBLS(1,1)=R8WK-XVBLS(1,1)
  13920. C IMPLEMENT ADDING AND SUBTRACTING SAVED SHEETS FROM CURRENT.
  13921. C GOES TO RECALC MANUAL MODE SINCE RECALC WOULD MESS UP
  13922. C VALUES; FORMULAS GET UPDATED FROM LAST-READ SHEET NORMALLY.
  13923.     CALL XVBLST(NR,NC,XVBLS(1,1))
  13924. 982     Continue
  13925.     GOTO 7961
  13926. 6500    CONTINUE
  13927. C HERE READ MAPPINGS
  13928.     IRRW=IRRW-64000
  13929.     ICCL=ICCL-64000
  13930. C RESTORE OFFSETS TO NORMAL RANGE
  13931.         If(Ibin.eq.0)
  13932.      1  READ(CFORM2(1:35),6501,ERR=7961)II,III
  13933.         If(Ibin.eq.1)ii=i4s
  13934.         If(Ibin.eq.1)iii=i4t
  13935. 6501    FORMAT(2I7)
  13936.     NRDSP(IRRW,ICCL)=II
  13937.     NCDSP(IRRW,ICCL)=III
  13938. C GO BACK FOR MORE. INEFFICIENT STORAGE OF MAP BUT IT'S COMPACT
  13939. C CODE...
  13940.     GOTO 7961
  13941. 7964    CONTINUE
  13942.     CLOSE(4)
  13943. 9990    NXINI=0
  13944.     RETURN
  13945. 510    CONTINUE
  13946.     IRTN=1
  13947.     NXINI=0
  13948.     CLOSE(IOLVL)
  13949. c    CLOSE(11)
  13950. c    OPEN(5,FILE='CON:0/0/100/100/Analy Command')
  13951.     RETURN
  13952.     END
  13953. c -h- pmtx2.for    Tue Sep  2 10:58:55 1986    
  13954.     SUBROUTINE PMTX2(IRTCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  13955.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  13956.     CHARACTER*1 LINE(80)
  13957.     CALL GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
  13958.      1  ID2B,RETCD)
  13959. C GET LOC OF MATRIX A (MUST BE SQUARE)
  13960.     IBGN=LSTCHR+1
  13961.     IF(RETCD.NE.0.OR.IMXX.LE.1)GOTO 1000
  13962.     IF(LINE(LSTCHR).NE.',')GOTO 300
  13963.     CALL GMTX(LINE,IBGN,LSTCHR,IDXA,IDXB,IDYA,
  13964.      1  IDYB,RETCD)
  13965. C GET LOC OF MATRIX X (RESULT).
  13966.     IBGN=LSTCHR+1
  13967.     IF(RETCD.NE.0.OR.IMXX.LE.2)GOTO 1000
  13968.     IF(LINE(LSTCHR).NE.',')GOTO 300
  13969.     CALL GMTX(LINE,IBGN,LSTCHR,IDBA,IDBB,IDCA,
  13970.      1  IDCB,RETCD)
  13971.     IBGN=LSTCHR+1
  13972. C GET LOC OF MATRIX B (AX=B), THE OTHER HALF OF OUR GIVENS
  13973. C IF WE FALL TO HERE, ALL LOOKS OK, SO LEAVE RETCD ALONE.
  13974. C HOWEVER IF ANY ERRS HAVE OCCURRED, RETCD IS ALREADY SET TO 3
  13975. C FOR ERROR...
  13976. 1000    RETURN
  13977. 300    CONTINUE
  13978.     RETCD=3
  13979.     RETURN
  13980.     END
  13981. c -h- postvl.for    Tue Sep  2 10:58:55 1986    
  13982.     SUBROUTINE POSTVL (RETCD)
  13983. C COPYRIGHT (C) 1983 GLENN EVERHART
  13984. C ALL RIGHTS RESERVED
  13985. C 60=MAX REAL ROWS
  13986. C 301=MAX REAL COLS
  13987. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  13988. C VBLS AND TYPE DIMENSIONED 60,301
  13989. C **************************************************
  13990. C *                                                *
  13991.  
  13992. C *      SUBROUTINE  POSTVL (RETCD)                *
  13993. C *                                                *
  13994. C **************************************************
  13995. C
  13996. C
  13997. C  CONVERTS POSTFIX EXPRESSIONS IN STACK 1 TO A VALUE
  13998. C
  13999. C
  14000. C    RETCD    MEANING
  14001. C
  14002. C    1    O.K.
  14003. C    2    ERROR
  14004. C
  14005. C POSTVL CALLS
  14006. C
  14007. C CALBIN    CALCULATES BINARY OPERATIONS
  14008. C CALUN     CALCULATES UNARY OPERATIONS
  14009. C ERRMSG    PRINTS OUT ERROR MESSAGES
  14010. C VAROUT    OUTPUTS THE VALUE OF A VARIABLE
  14011. C
  14012. C
  14013. C
  14014. C
  14015. C POSTVL IS CALLED BY CALC
  14016. C
  14017. C
  14018. C
  14019. C
  14020. C VARIABLE    USE
  14021. C _________ ___________________________
  14022. C
  14023. C    I,K     TEMPORARY VALUES
  14024. C
  14025. C    PT1     POINTS TO TOP ELEMENT IN STACK1
  14026. C
  14027. C    RETCD   RETURN CODE: 1=O.K., 2=ERROR
  14028. C
  14029. C    RETCD2  USED TO HOLD RETURN CODE WHEN CALLS TO
  14030. C            OTHER ROUTINES ARE MADE.
  14031. C
  14032. C    ST1PT   STACK 1 POINTER.
  14033. C
  14034. C    ST2PT   STACK 2 POINTER.
  14035. C
  14036. C    ST1TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 1
  14037. C
  14038. C    ST2TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 2
  14039. C
  14040. C    STACK1  HOLDS ORIGINAL POSTFIX EXPRESSION.
  14041. C
  14042. C    STACK2  USED TO EVALUATE EXPRESSION IN STACK1.
  14043. C
  14044. C    TYPE(27) HOLDS THE DATA TYPE FOR EACH OF THE VARIABLES.
  14045. C
  14046. C    AVBLS(100,27) HOLDS VALUES OF VARIABLES.
  14047. C    VBLS(8,60,301) HOLDS VALUE OF COMPLEXLY-NAMED VARIABLES. 1ST 27 ELEMENTS
  14048. C    ARE PLACE HOLDERS FOR AVBLS; ROUTINES THAT GENERATE DIMENSIONS ID1,ID2
  14049. C    FOR VBLS RETURN DIMENSIONS 1-27,1 FOR A-Z,%. THESE RESULT IN AVBLS
  14050. C    ARRAY BEING USED. VBLS ARRAY (MAX LENGTH 8 BYTES/VARIABLE) IS USED
  14051. C    FOR OTHER VARIABLES WHOSE NAMES ARE <ALPHA><ALPHA><NUM><NUM>
  14052. C    (WITH OPTION FOR ANY REASONABLE # OF ALPHAS AND NUMERICS BUT CLAMPED
  14053. C    AT 60,301 VALUES TO WORK CORRECTLY.)
  14054. C
  14055. C    VIEWSW   VIEW SWITCH:
  14056. C                0 = OFF
  14057. C                1 = DISPLAY COMMANDS
  14058. C                2 = DISPLAY VALUE OF EXPRESSIONS
  14059. C                3 = DISPLAY ALL
  14060. C
  14061. C
  14062. C
  14063. C    SUBROUTINE POSTVL (RETCD)
  14064. C
  14065.     InTeGer*4 LEVEL,NONBLK,LEND
  14066.     InTeGer*4 PT1
  14067.     InTeGer*4 VIEWSW,BASED
  14068.     InTeGer*4 RETCD,RETCD2,VLEN(9)
  14069.     InTeGer*4 TYPE(1,1)
  14070.     InTeGer*4 ST1TYP(40),ST2TYP(40)
  14071.     InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
  14072.     InTeGer*4 I,K
  14073. C
  14074.     CHARACTER*1 LINE(80)
  14075.     CHARACTER*1 STACK1(8,40), STACK2(8,40),AVBLS(20,27)
  14076.     CHARACTER*1 VBLS(8,1,1)
  14077. C
  14078.     COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  14079.      ;           ST1LIM,ST2LIM
  14080.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  14081.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  14082. C
  14083. C
  14084. C
  14085. C
  14086.     RETCD=1
  14087. C
  14088. C
  14089. C IF THERE IS ONE ELEMENT IN STACK1 AND IT IS NOT
  14090. C A NUMBER, THE EXPRESSION IS ILLEGAL (GO TO 95).
  14091.     IF(ST1PT.EQ.2.AND.ST1TYP(1).GT.30)GO TO 95
  14092. C
  14093. C
  14094. 10    IF (ST1PT.GT.2) GOTO 40
  14095.     IF (ST1PT.EQ.1) GOTO 95
  14096. C
  14097. C
  14098. C ***************************************
  14099. C ****** ONLY 1 ELEMENT ON STACK 1 ******
  14100. C ***************************************
  14101.     K=VLEN(ST1TYP(ST1PT-1))
  14102. C
  14103. C
  14104. C COPY INTO VARIABLE %
  14105.     DO 20 I=1,K
  14106. 20    AVBLS(I,27)=STACK1(I,1)
  14107.     CALL TYPSET(27,1,ST1TYP(1))
  14108. C    TYPE(27,1)=ST1TYP(1)
  14109. C
  14110. C
  14111. C OUTPUT VALUE OF %
  14112.     IF (VIEWSW.GT.1) CALL VAROUT(27,1)
  14113.     RETURN
  14114. C
  14115. C
  14116. C  MORE THAN ONE ELEMENT ON STACK1
  14117. 40    CONTINUE
  14118.     IF (ST1TYP(ST1PT-1).LE.30) GOTO 90
  14119.     IF (ST2PT.LE.ST2LIM) GOTO 45
  14120. C
  14121. C
  14122. C *** ERROR *** STACK 2 OVERFLOW
  14123.     CALL ERRMSG(9)
  14124. 43    RETCD=2
  14125.     RETURN
  14126. C
  14127. C
  14128. C
  14129. C
  14130. C ****************************************
  14131. C ****** OPERATOR SO PUT ON STACK 2 ******
  14132. C ****************************************
  14133. 45    ST2TYP(ST2PT)=ST1TYP(ST1PT-1)
  14134.     ST2PT=ST2PT+1
  14135.     ST1PT=ST1PT-1
  14136.     IF(ST1PT.EQ.1)GO TO 95
  14137.     GOTO 40
  14138. C
  14139. C
  14140. C
  14141. C
  14142. C
  14143. C *********************
  14144. C ****** OPERAND ******
  14145. C *********************
  14146. C
  14147. C FIRST BE SURE THAT THERE IS AN OPERATOR INVOLVED ON STACK 2
  14148. C (IF ONLY ONE ELEMENT IN STACK 1 YOU SHOULD NOT BE HERE).
  14149. 90    IF(ST2PT.NE.1)GO TO 110
  14150. C
  14151. C
  14152. C *** ERROR *** ILLLEGAL EXPRESSION
  14153. 95    CALL ERRMSG(8)
  14154.     GO TO 43
  14155. C
  14156. C
  14157. C
  14158. C
  14159. C ENTER HERE AFTER APPLYING AN OPERATOR TO A NUMBER
  14160. 100    IF (ST2PT.EQ.1) GOTO 10
  14161. 110    K=ST2TYP(ST2PT-1)
  14162. C
  14163. C IF A UNARY OPERATOR, GO TO 190
  14164.     IF ((K.GT.30.AND.K.LE.47).OR.K.EQ.111) GOTO 190
  14165. C
  14166. C
  14167. C IF A BINARY OPERATOR, GO TO 170
  14168.     IF (K.GE.110.AND.K.LE.117) GOTO 170
  14169.     IF(K.EQ.200)GO TO 170
  14170. C
  14171. C IF ELEMENT ON STACK2 AT ST2PT-1 IS AN OPERAND, APPLY CALBIN AGAIN
  14172.     IF(K.LE.30) GO TO 180
  14173.     STOP 110
  14174. C
  14175. C
  14176. C
  14177. C
  14178. C ***************************************************************
  14179. C ****** CALBIN CALCULATES THE BINARY VALUE OF AN OPERATOR ******
  14180. C ***************************************************************
  14181. C  UPON ENTRANCE:
  14182. C    OPERAND 1 IS IN STACK 1
  14183. C    OPERAND 2 IS IN STACK 2
  14184. C    OPERATOR IS BELOW OPERAND 2
  14185. C  UPON EXIT RESULT IS ON STACK 1
  14186. C
  14187. C    RETURN CODE    MEANING
  14188. C
  14189. C    1        O.K.
  14190. C    2        OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
  14191. C    3        ERROR ENCOUNTERED
  14192. C
  14193. C
  14194. 170    CONTINUE
  14195. C
  14196. C
  14197. C FIRST PUT OPERAND 2 ONTO STACK 2
  14198.     PT1=ST1PT-1
  14199.     ST2TYP(ST2PT)=ST1TYP(PT1)
  14200.     K=VLEN(ST2TYP(ST2PT))
  14201.     DO 175 I=1,K
  14202. 175    STACK2(I,ST2PT)=STACK1(I,PT1)
  14203.     ST1PT=ST1PT-1
  14204.     IF(ST1PT.EQ.1)GO TO 95
  14205.     ST2PT=ST2PT+1
  14206. C
  14207. C
  14208. C IF OPERAND 1 IS AN OPERATOR, PUT IT ON STACK 2 (GO TO 45)
  14209.     IF(ST1TYP(ST1PT-1).GT.30) GO TO 45
  14210. 180    CALL CALBIN (RETCD2)
  14211.     GOTO (100,1000,43), RETCD2
  14212.     STOP 180
  14213. C
  14214. C
  14215. C
  14216. C
  14217. C
  14218. C ********************************************************************
  14219. C ****** CALL CALUN TO CALCULATE THE VALUE OF A UNARY OPERATION ******
  14220. C ********************************************************************
  14221. C    OPERATOR IS IN STACK 2
  14222. C    OPERAND IS IN STACK 1
  14223. C    UPON EXIT, OPERATOR IS POPPED OFF STACK 2
  14224. C
  14225. C    RETURN CODE    MEANING
  14226. C
  14227. C    1        O.K.
  14228. C    2        OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
  14229. C    3        ERROR ENCOUNTERED
  14230. C
  14231. C
  14232. 190    CALL CALUN (RETCD2)
  14233.     GOTO(100,43),RETCD2
  14234.     STOP 190
  14235. C
  14236. C
  14237. 1000    RETURN
  14238.     END
  14239. c -h- prtcon.for    Tue Sep  2 10:58:55 1986    
  14240. C **********************************
  14241. C *                                *
  14242. C *    INTERNAL FUNCTION PRTCON    *
  14243. C *                                *
  14244. C **********************************
  14245. C CALLED BY MOUT ONLY
  14246. C CONVERTS 0 TO APPROPRIATE NUMBER FOR PRINTING WITH VECTOR DIGITS
  14247.     FUNCTION PRTCON(L1,IBASE)
  14248.     InTeGer*4 BASE(3)
  14249.     InTeGer*4 IBASE,K
  14250.     CHARACTER*1 L1,PRTCON,DIGITS(16,3)
  14251.     COMMON /DIGV/ DIGITS
  14252.     DATA BASE /10,8,16/
  14253.     PRTCON=L1
  14254.     IF(L1.EQ.0)PRTCON=CHAR(BASE(IBASE))
  14255.     K=ICHAR(PRTCON)
  14256.     PRTCON=DIGITS(K,IBASE)
  14257.     RETURN
  14258.     END
  14259. c -h- rassig.for    Tue Sep  2 10:58:55 1986    
  14260.     SUBROUTINE RASSIG(IUNIT,NAME)
  14261. C
  14262. C
  14263.     CHARACTER*1 NAME(50)
  14264.     InTeGer*4 IUNIT
  14265. C &&&& MS FTN 3.2
  14266.     LOGICAL LEXIST
  14267. C &&&&
  14268.     CHARACTER*20 WK
  14269.     CHARACTER*1 WK1(20)
  14270.     EQUIVALENCE(WK(1:1),WK1(1))
  14271. C JUST TRY AND NULL FILL A NAME TO USE.
  14272.     DO 1 N=1,20
  14273.     WK1(N)=' '
  14274. 1    CONTINUE
  14275.     DO 2 N=1,20
  14276.     II=ICHAR(NAME(N))
  14277.     IF(II.LT.32)GOTO 3
  14278.     WK1(N)=CHAR(II)
  14279. C1    CONTINUE
  14280. 2    CONTINUE
  14281. 3    CONTINUE
  14282. C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
  14283. C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
  14284. C AVOID CRASHES IF THE FILE ISN'T THERE...
  14285. C MSDOS FORTRAN 3.2 AND LATER FEATURE...
  14286. C &&&&
  14287. C
  14288. C    INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
  14289. C
  14290.     INQUIRE(FILE=WK(1:20),EXIST=LEXIST)
  14291.     IF(LEXIST)GOTO 100
  14292. C FILE DOES NOT EXIST, SO CREATE IT HERE.
  14293. C IF CREATE FAILS WE LOSE TOO...
  14294. c    CALL UVT100(1,1,1)
  14295. c    CALL SWRT('File not found. Attempting to create.',37)
  14296. c    OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
  14297. c     1  FORM='FORMATTED')
  14298. c    CLOSE(IUNIT)
  14299. c
  14300. c On failure to open a file, create a window instead which
  14301. c can be its surrogate...
  14302. c
  14303.     Open(Iunit,file='CON:200/100/400/60/RdErr ' // wk,
  14304.      1  Access='Sequential',form='Formatted')
  14305. C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
  14306. C WILL GET EOF ON START, BUT THAT'S TOO BAD...
  14307.     Goto 77
  14308. 100    CONTINUE
  14309. C &&&&
  14310. C IF JUST CALL ASSIGN, ASSUME FOR READ.
  14311.     OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
  14312.      1  FORM='FORMATTED')
  14313. 77    CONTINUE
  14314. C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
  14315. C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
  14316.     RETURN
  14317.     END
  14318. c -h- recalc.f40    Tue Sep  2 10:58:55 1986    
  14319.     SUBROUTINE RECALC
  14320. C COPYRIGHT (C) 1983,1984,1985,1986 GLENN EVERHART
  14321. C ALL RIGHTS RESERVED
  14322. C RECALCULATE COMMAND
  14323. C RECOMPUTE ALL ELEMENTS OF SPREADSHEET WHERE VALID.
  14324. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  14325. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  14326. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  14327. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  14328. C FROM THE DISK BASED FILE HERE.
  14329.     Include AParms.inc
  14330.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  14331.     INTEGER*4 VNLT
  14332. C ***<<< XVXTCD COMMON START >>>***
  14333.     CHARACTER*1 OARRY(100)
  14334.     InTeGer*4 OSWIT,OCNTR
  14335. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  14336. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  14337.     InTeGer*4 IPS1,IPS2,MODFLG
  14338. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  14339.        InTeGer*4 XTCFG,IPSET,XTNCNT
  14340.        CHARACTER*1 XTNCMD(80)
  14341. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  14342. C VARY FLAG ITERATION COUNT
  14343.     INTEGER KALKIT
  14344. C    COMMON/VARYIT/KALKIT
  14345.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  14346.     InTeGer*4 RCMODE,IRCE1,IRCE2
  14347. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  14348. C     1  IRCE2
  14349. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  14350. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  14351. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  14352. C RCFGX ON.
  14353. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  14354. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  14355. C  AND VM INHIBITS. (SETS TO 1).
  14356.     INTEGER*4 FH
  14357. C FILE HANDLE FOR CONSOLE I/O (RAW)
  14358. C    COMMON/CONSFH/FH
  14359.     CHARACTER*1 ARGSTR(52,4)
  14360. C    COMMON/ARGSTR/ARGSTR
  14361.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  14362.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  14363.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  14364.      3  IRCE2,FH,ARGSTR
  14365. C ***<<< XVXTCD COMMON END >>>***
  14366. CCCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  14367. CCCC     1  IRCE1,IRCE2
  14368. CCCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  14369. CCCC     1  IRCE1,IRCE2
  14370. C ***<<< KLSTO COMMON START >>>***
  14371.     InTeGer*4 DLFG
  14372. C    COMMON/DLFG/DLFG
  14373.     InTeGer*4 KDRW,KDCL
  14374. C    COMMON/DOT/KDRW,KDCL
  14375.     InTeGer*4 DTRENA
  14376. C    COMMON/DTRCMN/DTRENA
  14377.     REAL*8 EP,PV,FV
  14378.     DIMENSION EP(20)
  14379.     INTEGER*4 KIRR
  14380. C    COMMON/ERNPER/EP,PV,FV,KIRR
  14381.     InTeGer*4 LASTOP
  14382. C    COMMON/ERROR/LASTOP
  14383.     CHARACTER*1 FMTDAT(9,76)
  14384. C    COMMON/FMTBFR/FMTDAT
  14385.     CHARACTER*1 EDNAM(16)
  14386. C    COMMON/EDNAM/EDNAM
  14387.     InTeGer*4 MFID(2),MFMOD(2)
  14388. C    COMMON/FRM/MFID,MFMOD
  14389.     InTeGer*4 JMVFG,JMVOLD
  14390. C    COMMON/FUBAR/JMVFG,JMVOLD
  14391.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  14392.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  14393. C ***<<< KLSTO COMMON END >>>***
  14394. CCC    InTeGer*4 DLFG
  14395. CCC    COMMON/DLFG/DLFG
  14396. C DLFG=1 IF D## FORMS HAVE BEEN SEEN, ELSE 0
  14397.     DIMENSION FORM(128),FVLD(1,1)
  14398.     COMMON/FVLDC/FVLD
  14399. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  14400. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  14401. C SO INITIALLY IGNORE.
  14402. C FVLD=-2 OR -3 = DISPLAY FORMULA
  14403. C FVLD=3 NUMERIC, COMPUTE ONCE THEN SET FVLD TO 2
  14404. C FVLD=2 NUMERIC CONSTANT, ALREADY COMPUTED... DO NOT RECOMPUTE.
  14405. C
  14406. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  14407. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  14408. C ***<<<< RDD COMMON START >>>***
  14409.     InTeGer*4 RRWACT,RCLACT
  14410. C    COMMON/RCLACT/RRWACT,RCLACT
  14411.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  14412.      1  IDOL7,IDOL8
  14413. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  14414. C     1  IDOL7,IDOL8
  14415.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  14416. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  14417.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  14418. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  14419. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  14420. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  14421.     InTeGer*4 KLVL
  14422. C    COMMON/KLVL/KLVL
  14423.     InTeGer*4 IOLVL,IGOLD
  14424. C    COMMON/IOLVL/IOLVL
  14425. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  14426. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  14427.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  14428.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  14429.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  14430.      3  k3dfg,kcdelt,krdelt,kpag
  14431. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  14432. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  14433. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  14434. C ***<<< RDD COMMON END >>>***
  14435. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  14436. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  14437.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  14438.     COMMON/D2R/NRDSP,NCDSP
  14439.     InTeGer*4 TYPE(1,1),VLEN(9)
  14440.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  14441. CCC    InTeGer*4 RRWACT,RCLACT
  14442. CCC    COMMON/RCLACT/RRWACT,RCLACT
  14443. CCC    InTeGer*4 KDRW,KDCL
  14444. CCC    COMMON /DOT/KDRW,KDCL
  14445.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  14446.     InTeGer*4 PRS,PCS,DRS,DCS
  14447.     Character*6 cwrk6
  14448.     PRS=PROW
  14449.     PCS=PCOL
  14450.     DRS=DROW
  14451.     DCS=DCOL
  14452.     IF(RCMODE.EQ.2)GOTO 5500
  14453. C THE FOLLOWING 2 LOOPS DEFINE ORDER OF CALCULATION.
  14454. C HERE THIS IS: OUTER LOOP ON ROWS (ACROSS), INNER LOOP ON COLUMNS (DOWN).
  14455. C NOTE THAT N2 DEFINES THE SHEET. SINCE 1 IS THE ACCUMULATORS, JUST GO THRU
  14456. C FOR THE SHEET, NOT THE AC'S.
  14457.     DO 1 N2=2,RCLACT
  14458.     IF(IDOL8.EQ.0)GOTO 8220
  14459. C VIEW HACK HERE
  14460. C DISPLAY ROW NUMBER FOLLOWED BY BARE CR DURING RECALC
  14461.     KKKK=13
  14462. C 13 IS ASCII CARRIAGE RETURN
  14463.     write(cwrk6,8221)n2
  14464.     call uvt100(1,llcmd,60)
  14465.     call vwrt(cwrk6,5)
  14466. c    REWIND 11
  14467. c    WRITE(11,8221)N2,KKKK
  14468. c    REWIND 11
  14469. 8221    FORMAT(I5,1A1)
  14470. 8220    CONTINUE
  14471.     N1=1
  14472. 220    CONTINUE
  14473. C    DO 2 N1=1,60
  14474. C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
  14475. C FASTER THAN STANDARD LOOP METHOD.
  14476. C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
  14477. C OF FVLDGT AND FVPEEK.
  14478. C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
  14479. C 
  14480. CCCC COMMENT 2 LINES OUT WHEN FAST FVLDGT IS IN TO SPEED UP MORE...
  14481. CCCC EXTRA LOGIC IN FVPEEK DOESN'T USUALLY PAY FOR ITSELF...
  14482. CCC    CALL FVPEEK(N1,N2,NN1)
  14483. CCC    N1=NN1
  14484.     CALL FVLDGT(N1,N2,FVLD(1,1))
  14485.     IIFV=JCHAR(FVLD(1,1))
  14486.     IF (IIFV.LE.0) GOTO 2
  14487.     IRRX=(N2-1)*MCols+N1
  14488. C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
  14489. C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
  14490.     IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 2
  14491.     KDRW=N1
  14492.     KDCL=N2
  14493.     PROW=N1
  14494.     PCOL=N2
  14495. C SEE IF THIS PHYS COL HAS A DISPLAY COL. AND IF SO SET THAT UP.
  14496. C ONLY SET TO DISPLAYED LOCS HERE TO MINIMIZE SEARCH TIME.
  14497. C NEED THIS TO HANDLE D## FORMS...
  14498.     IF (DLFG.EQ.0)GOTO 95
  14499. C IF NEVER HAD A D## FORM FORGET LOOKING FOR DISPLAY LOCS.
  14500.     DO 20 M2=1,DCLV
  14501.     DO 10 M1=1,DRWV
  14502.     M1X=M1
  14503.     M2X=M2
  14504. C LOOK FOR DISPLAY COORDS EVEN IF IN HYPERSPACE
  14505. C WE FIND ONE IF INDEX FROM REFLECT IS SAME AS WHAT
  14506. C WE'RE LOOKING FOR...
  14507.     IF(NRDSP(M1,M2).EQ.N1.AND.NCDSP(M1,M2).EQ.N2)GOTO 9
  14508. 10    CONTINUE
  14509. 20    CONTINUE
  14510. 95    CONTINUE
  14511. C HERE IF CELL NOT DISPLAYED... SEE IF NEEDS DOING IN RI, RE MODES
  14512.     IF(RCMODE.LE.0)GOTO 9
  14513.     IF(PROW.NE.IRCE1.OR.PCOL.NE.IRCE2)GOTO 2
  14514. C SKIP UNLESS ENTER CELL.
  14515. 9    CONTINUE
  14516. C IF NO DISPLAY ROW, LEAVE AT LOW RIGHT...
  14517. C USE SAVED VALUES SO WE DON'T RELY ON DO LOOP INDEX AFTER LOOP END.
  14518.     DROW=M1X
  14519.     DCOL=M2X
  14520.     CALL WRKFIL(IRRX,FORM,0)
  14521. C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
  14522.     LFST=1
  14523. C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
  14524. C THEM UP A BIT.
  14525.     DO 56 N=1,109
  14526.     LLST=111-N
  14527.     IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 57
  14528.     FORM(LLST)=Char(0)
  14529. 56    CONTINUE
  14530. 57    CONTINUE
  14531.     FORM(LLST)=Char(0)
  14532.     FORM(111)=Char(0)
  14533. C    IF(ICHAR(FORM(118)).NE.15)GOTO 2
  14534. c ****&&&& experimental...
  14535. c &&&&&**** replace llst by llst-1
  14536. c    llst=max0(1,llst-1)
  14537.     CALL DOENTR(FORM,LFST,LLST)
  14538. C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
  14539. C    CALL FVLDGT(N1,N2,FVLD(1,1))
  14540.     IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
  14541. 2    CONTINUE
  14542.     N1=N1+1
  14543.     IF(N1.LE.RRWACT)GOTO 220
  14544. 1    CONTINUE
  14545.     GOTO 5600
  14546. 5500    CONTINUE
  14547. C RCMODE=2 AND NOT RM MODE
  14548. C (IN RM MODE, RECALC IS NOT CALLED...)
  14549.     DO 1701 M2=1,DCLV
  14550.     IF(IDOL8.EQ.0)GOTO 8222
  14551. C VIEW HACK HERE
  14552. C DISPLAY ROW NUMBER FOLLOWED BY BARE CR DURING RECALC
  14553.     KKKK=13
  14554. C 13 IS ASCII CARRIAGE RETURN
  14555.     write(cwrk6,8221)n2
  14556.     call uvt100(1,llcmd,60)
  14557.     call vwrt(cwrk6,5)
  14558. C 13 IS ASCII CARRIAGE RETURN
  14559. c    REWIND 11
  14560. c    WRITE(11,8221)M2,KKKK
  14561. c    REWIND 11
  14562. 8222    CONTINUE
  14563.     KDRW=1
  14564.     KDCL=2
  14565.     DO 1702 M1=1,DRWV
  14566. C TO HANDLE DISPLAY WHEREVER IT MAY BE, FIND ID OF PHYS CELL AND
  14567. C CONVERT TO PHYS ROW, COL AGAIN REGARDLESS OF ALIAS...
  14568. C (NOTE CALC ORDER IS THEREFORE DISPLAY ORDER, NOT SHEET ORDER...)
  14569.     K=NRDSP(M1,M2)
  14570.     KK=NCDSP(M1,M2)
  14571.     CALL REFLECT(KK,K,IV1)
  14572.     NRC=IV1-1
  14573.     N1=MOD(NRC,MCols)+1
  14574.     N2=((NRC-N1+1)/MCols)+1
  14575. C COMPUTE PHYS ROW, COL FROM DISPLAY COORDINATES.
  14576. C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
  14577. C FASTER THAN STANDARD LOOP METHOD.
  14578. C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
  14579. C OF FVLDGT AND FVPEEK.
  14580. C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
  14581.     If (N1.gt.RRWACT.or.N2.Gt.RCLACT) GOTO 1702
  14582.     CALL FVLDGT(N1,N2,FVLD(1,1))
  14583.     IIFV=JCHAR(FVLD(1,1))
  14584.     IF (IIFV.LE.0) GOTO 1702
  14585. C FORGET THIS CELL IF NOT A COMPUTABLE ONE...
  14586.     IRRX=IV1
  14587. C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
  14588. C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
  14589.     IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 1702
  14590.     KDRW=N1
  14591.     KDCL=N2
  14592.     PROW=N1
  14593.     PCOL=N2
  14594.     DROW=M1
  14595.     DCOL=M2
  14596.     CALL WRKFIL(IRRX,FORM,0)
  14597. C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
  14598.     LFST=1
  14599. C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
  14600. C THEM UP A BIT.
  14601. C (ALSO GUARANTEE WE HAVE LOTS OF NULLS AT END TO TERMINATE INDEX ROUTINES)
  14602.     DO 756 N=1,109
  14603.     LLST=111-N
  14604.     IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 757
  14605.     FORM(LLST)=Char(0)
  14606. 756    CONTINUE
  14607. 757    CONTINUE
  14608.     FORM(LLST)=Char(0)
  14609.     FORM(111)=Char(0)
  14610. C CALL DOENTR TO DO THE ACTUAL COMPUTATION WORK...
  14611.     CALL DOENTR(FORM,LFST,LLST)
  14612. C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
  14613.     IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
  14614. 1702    CONTINUE
  14615. 1701    CONTINUE
  14616. C END OF COMPUTATION OVER DISPLAYS
  14617. C    GOTO 5600
  14618. 5600    CONTINUE
  14619.     PROW=PRS
  14620.     PCOL=PCS
  14621.     DROW=DRS
  14622.     DCOL=DCOL
  14623. C FORCE FUNCTION WORKS ONCE ONLY.
  14624.     RCONE=0
  14625.     RCMODE=IABS(RCMODE)
  14626. C SET FOR TEMP. RECALC-ALL MODES TO RETURN TO NORMAL.
  14627.     IRCE1=0
  14628.     IRCE2=0
  14629.     RETURN
  14630.     END
  14631. c -h- reflect.f40    Tue Sep  2 10:58:55 1986    
  14632.     SUBROUTINE REFLEC(ID1,ID2,ID)
  14633. C FORM ID OUT OF ID1,ID2 BUT USING REFLECTED VALUES SO THAT
  14634. C RESULT ID IS ALWAYS IN PRIME AREA.
  14635.     Include AParms.inc
  14636.     InTeGer*4 ID,ID1,ID2,IDD1,IDD2
  14637. C ***<<< NULETC COMMON START >>>***
  14638.     InTeGer*4 ICREF,IRREF
  14639. C    COMMON/MIRROR/ICREF,IRREF
  14640.     InTeGer*4 MODPUB,LIMODE
  14641. C    COMMON/MODPUB/MODPUB,LIMODE
  14642.     InTeGer*4 KLKC,KLKR
  14643.     REAL*8 AACP,AACQ
  14644. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  14645.     InTeGer*4 NCEL,NXINI
  14646. C    COMMON/NCEL/NCEL,NXINI
  14647.     CHARACTER*1 NAMARY(20,MRows)
  14648. C    COMMON/NMNMNM/NAMARY
  14649.     InTeGer*4 NULAST,LFVD
  14650. C    COMMON/NULXXX/NULAST,LFVD
  14651.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  14652.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  14653. C ***<<< NULETC COMMON END >>>***
  14654. CCC    COMMON/MIRROR/ICREF,IRREF
  14655. C IN RECALC WE MOVE OVER PRIME AREA ONLY AND SEARCH FOR CELLS IN
  14656. C DISPLAY AREA THERE. THIS IMPLIES THAT WE DON'T FIND DISPLAY
  14657. C COORDS OF CELLS IN EXTENDED AREAS THERE.  THEREFORE THE RI AND RE
  14658. C MODES FAIL COMPLETELY THERE. SINCE WE WANT THE SYSTEM TO WORK IN
  14659. C A PREDICTABLE WAY, FORCE RECALC MODE (I.E., R OR RM MODES) THERE TO
  14660. C ALLOW CELLS TO BE COMPUTED.
  14661. C NOTE THAT IF WE ARE IN THE PRIME AREA AND ISSUE AN RE OR RI COMMAND,
  14662. C THAT MODE SHOULD STAY SET SO LONG AS WE STAY THERE SINCE THE RE OR
  14663. C RI MODES WILL INHIBIT COMPUTING OUTSIDE THAT AREA (AS LONG AS NOTHING
  14664. C REFLECTS INTO IT) SO THERE WILL BE NO REASON FOR THIS TO BE CALLED
  14665. C TO REFLECT SOMETHING BACK TO PRIME AREA UNTIL A R COMMAND IS GIVEN
  14666. C OR THE DISPLAY MOVES OFF THE EDGE OF THE PRIME 60 BY 301 AREA.
  14667. C
  14668. C ***<<< XVXTCD COMMON START >>>***
  14669.     CHARACTER*1 OARRY(100)
  14670.     InTeGer*4 OSWIT,OCNTR
  14671. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  14672. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  14673.     InTeGer*4 IPS1,IPS2,MODFLG
  14674. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  14675.        InTeGer*4 XTCFG,IPSET,XTNCNT
  14676.        CHARACTER*1 XTNCMD(80)
  14677. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  14678. C VARY FLAG ITERATION COUNT
  14679.     INTEGER KALKIT
  14680. C    COMMON/VARYIT/KALKIT
  14681.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  14682.     InTeGer*4 RCMODE,IRCE1,IRCE2
  14683. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  14684. C     1  IRCE2
  14685. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  14686. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  14687. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  14688. C RCFGX ON.
  14689. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  14690. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  14691. C  AND VM INHIBITS. (SETS TO 1).
  14692.     INTEGER*4 FH
  14693. C FILE HANDLE FOR CONSOLE I/O (RAW)
  14694. C    COMMON/CONSFH/FH
  14695.     CHARACTER*1 ARGSTR(52,4)
  14696. C    COMMON/ARGSTR/ARGSTR
  14697.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  14698.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  14699.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  14700.      3  IRCE2,FH,ARGSTR
  14701. C ***<<< XVXTCD COMMON END >>>***
  14702. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE
  14703. CCC    InTeGer*4 IRCE1,IRCE2
  14704. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,IRCE2
  14705.     IDD1=MAX0(ID1,1)
  14706.     IDD2=ID2
  14707. C ACCEPT TRICK CALLS WITH ID1=0 AS FROM GMSUBS, MTXEQU,
  14708. C AND MDST
  14709.     IF(ID1.LT.1)GOTO 2000
  14710. 4000    CONTINUE
  14711.     IF(IDD2.LE.MCols)GOTO 1000
  14712.     IDD2=IDD2-MCols
  14713.     IDD1=IDD1+IRREF
  14714. c    RCMODE=0
  14715. C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
  14716.     GOTO 4000
  14717. 1000    CONTINUE
  14718.     IF(IDD1.LE.MRows)GOTO 2000
  14719.     IDD1=IDD1-MRows+1
  14720.     IDD2=IDD2+ICREF
  14721. c    RCMODE=0
  14722. C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
  14723.     GOTO 4000
  14724. 2000    CONTINUE
  14725.     ID=(IDD1-1)*MCols+IDD2
  14726.     RETURN
  14727.     END
  14728. c -h- relvbl.for    Tue Sep  2 10:58:55 1986    
  14729.     SUBROUTINE RELVBL(LNIN,LNOUT,INRW,INCL,JOUTR,JOUTC,JRTR,JRTC)
  14730. C RELOCATE VARIABLES BELOW/RIGHT OF JRTR,JRTC INTO LNOUT FROM LNIN
  14731. C    PARAMETER CUP=1,ED=11,EL=12
  14732.     Include AParms.inc
  14733.     CHARACTER*1 NAME(4),NUMBER(6)
  14734.     CHARACTER*1 LNIN,LNOUT
  14735.     CHARACTER*6 NUMBR6
  14736.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  14737.     DIMENSION LNIN(128),LNOUT(128)
  14738. C ***<<<< RDD COMMON START >>>***
  14739.     InTeGer*4 RRWACT,RCLACT
  14740. C    COMMON/RCLACT/RRWACT,RCLACT
  14741.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  14742.      1  IDOL7,IDOL8
  14743. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  14744. C     1  IDOL7,IDOL8
  14745.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  14746. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  14747.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  14748. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  14749. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  14750. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  14751.     InTeGer*4 KLVL
  14752. C    COMMON/KLVL/KLVL
  14753.     InTeGer*4 IOLVL,IGOLD
  14754. C    COMMON/IOLVL/IOLVL
  14755. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  14756.     Integer*4 K3dfg,kcdelt,krdelt,kpag,idol9,idsptp
  14757. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  14758.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  14759.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  14760.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,Idsptp,Idol9,
  14761.      3  k3dfg,kcdelt,krdelt,kpag
  14762. C ***<<< RDD COMMON END >>>***
  14763. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  14764. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  14765. C    LOGICAL*2 L63,L192,L255,L127,L128
  14766.     LOGICAL*4 L1,L2
  14767. C    InTeGer*4 I63,I192,I255,I127,I128
  14768.     InTeGer*4 I63,I192,I127
  14769.     InTeGer*4 I1,I2
  14770. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  14771.     EQUIVALENCE (I1,L1),(I2,L2)
  14772. C    EQUIVALENCE (L127,I127),(L128,I128)
  14773. C    DATA I63/63/,I192/192/,I255/255/,I127/127/,I128/128/
  14774.     DATA I63/63/,I192/192/,I127/127/
  14775.     LI=1
  14776.     LO=1
  14777. C LI = INPUT LOCATION
  14778. C LO=OUTPUT LOCATION
  14779. 100    CONTINUE
  14780.     KSheet=0
  14781. C    IF(LNIN(LI).LT.'A'.OR.LNIN(LI).GT.'Z')GOTO 200
  14782.     LCC=ICHAR(LNIN(LI))
  14783. C IF WE HAVE 255,CODE,CODE THEN RELOCATE IN BINARY...
  14784.     IF(LCC.EQ.255)GOTO 500
  14785.     IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
  14786. C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
  14787.     IL1=LI
  14788.     LE=110
  14789.     LSTC=LE
  14790.     CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
  14791. C AVOID MESSING UP FUNCTION NAMES
  14792.     IF(ID2.EQ.1)IVLD=0
  14793. C    IF(ID2.EQ.1.AND.ID1.LE.27)IVLD=0
  14794.     IF(IVLD.EQ.0)GOTO 200
  14795. C FOUND VARIABLE. NOW GENERATE ASCII ANDSTUFF INTO OUTPUT.
  14796. C FIRST DON'T RELOCATE P## AND D## FORMS.
  14797.     IF(LNIN(LI+1).EQ.'#')GOTO 250
  14798. C RELOCATE NORMAL VARIABLE HERE.
  14799. C
  14800. C THE NEW VARIABLE IS TO BE DIFFERENT ONLY IF (ID1,ID2) HAS
  14801. C ID1.GT.JRTR AND ID2.GT.JRTC
  14802.     IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 210
  14803.     IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 210
  14804. C OK, KNOW NOW THAT WE HAVE TO RELOCATE ALL.
  14805. C THEREFORE ADD THE DIFFERENCE BETWEEN DEST AND SRC TO BOTH
  14806. C AND CLAMP TO VALID DIMENSIONS.
  14807.     IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
  14808.     IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
  14809. 906    ID1=MAX0(ID1,1)
  14810.     ID2=MAX0(ID2,1)
  14811. C CAN UNPACK THIS STUFF ALL RIGHT IN EXTENDED WAYS.
  14812.     ID1=MIN0(MRC,ID1)
  14813.     ID2=MIN0(MRC,ID2)
  14814. 210    CONTINUE
  14815.     KSHEET=0
  14816.     IF(K3DFG.LE.2)GOTO 2221
  14817. C RENAME CELLS BY 3D NAMES. (NOTE FLAG TO DO THIS; USE FOR DISPLAYS)
  14818. C ID1 GETS REDUCED BY COL. DELTA AND ID2 BY ROW DELTA
  14819. C UNTIL ONE OR BOTH ARE LESS THAN THE DELTAS. THEN THE %NNNN IS TACKED ON
  14820. C THE END. THIS PERMITS USERS TO DECIDE WHETHER THEY WANT THINGS TRANSLATED
  14821. C TO SHEET NUMBER FORMAT OR NOT.
  14822.     IF(KCDELT.LE.0.AND.KRDELT.LE.0)GOTO 2221
  14823.     KRR1=MRC
  14824.     KCC1=MRC
  14825.     IF(KCDELT.GT.0)KCC1=(ID1-1)/KCDELT
  14826.     IF(KRDELT.GT.0)KRR1=(ID2-2)/KRDELT
  14827.     KSH=MIN0(KRR1,KCC1)
  14828.     IF(KSH.GE.(MRC-100))GOTO 2221
  14829. C IF BOTH DELTAS ARE ZERO DON'T TOUCH ANYTHING.
  14830.     KSHEET=MAX0(KSH,0)
  14831. C KSHEET NONZERO FLAGS WE MAKE THE MOD
  14832.     IF(ID1.LT.KSHEET*KCDELT)GOTO 2220
  14833.     IF((ID2-1).LT.KSHEET*KRDELT)GOTO 2220
  14834.     ID1=ID1-KSHEET*KCDELT
  14835.     ID2=ID2-KSHEET*KRDELT
  14836. c222    CONTINUE
  14837.     GOTO 2221
  14838. 2220    CONTINUE
  14839.     KSHEET=0
  14840. 2221    CONTINUE
  14841.     CALL IN2AS(ID1,NAME)
  14842. C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
  14843.     IL2=ID2-1
  14844.     WRITE(NUMBR6(1:6),1000)IL2
  14845. C    ENCODE(6,1000,NUMBER)IL2
  14846. 1000    FORMAT(I6)
  14847. C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
  14848. C THROW OUT SPACES AND COPY THE REST.
  14849.     LI=LSTC
  14850.     DO 202 N=1,4
  14851.     IF(Ichar(NAME(N)).LE.32)GOTO 202
  14852.     LNOUT(LO)=NAME(N)
  14853.     LO=LO+1
  14854.     IF(LO.GT.110)GOTO 300
  14855. 202    CONTINUE
  14856.     IF(IDOL1.GT.0)LNOUT(LO)=36
  14857.     IF(IDOL1.GT.0.AND.LO.LE.109)LO=LO+1
  14858.     DO 203 N=1,6
  14859.     IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
  14860. C IF 32 ISN'T SPACE, LOSE
  14861.     LNOUT(LO)=NUMBER(N)
  14862.     LO=LO+1
  14863.     IF(LO.GT.110)GOTO 300
  14864. 203    CONTINUE
  14865.     IF(IDOL2.EQ.0)GOTO 275
  14866.     LNOUT(LO)=Char(36)
  14867.     IF(LO.LE.109)LO=LO+1
  14868. 275    Continue
  14869.     IF(KSHEET.EQ.0)GOTO 300
  14870. C ADD SHEET NUMBER CRUFT IF CALLED FOR.
  14871.     LNOUT(LO)=Char(37)
  14872. C 37 IS % SIGN
  14873.     IF(LO.LE.109)LO=LO+1
  14874.     NUMBR6(1:6)='      '
  14875.     WRITE(NUMBR6(1:6),1000)KSHEET
  14876. C    ENCODE(6,1000,NUMBER)KSHEET
  14877.     DO 1203 N=1,6
  14878.     IF(Ichar(NUMBER(N)).LE.32)GOTO 1203
  14879. C IF 32 ISN'T ASCII SPACE, LOSE.
  14880.     LNOUT(LO)=NUMBER(N)
  14881.     LO=LO+1
  14882.     IF(LO.GT.110)GOTO 300
  14883. 1203    CONTINUE
  14884. C NOW HAVE THE FULL VALUE ENCODED, INCLUDING SHEET NUMBER IF APPROPRIATE.
  14885. c    IF(LO.LE.109)LO=LO+1
  14886.     GOTO 300
  14887. 250    CONTINUE
  14888. C JUST COPY DISPLAY FORMS.
  14889.     IL1=LSTC-1
  14890.     DO 251 N=LI,IL1
  14891.     LNOUT(LO)=LNIN(N)
  14892.     LO=LO+1
  14893.     IF(LO.GT.110)GOTO 300
  14894. 251    CONTINUE
  14895.     LI=LSTC
  14896. C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
  14897.     GOTO 300
  14898. 200    LNOUT(LO)=LNIN(LI)
  14899.     LO=LO+1
  14900.     LI=LI+1
  14901. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  14902. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  14903.     LO=MIN0(LO,110)
  14904.     DO 400 N=LO,110
  14905. 400    LNOUT(N)=0
  14906.     DO 1 N=111,128
  14907. 1    LNOUT(N)=LNIN(N)
  14908. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  14909.     RETURN
  14910. 500    CONTINUE
  14911. C DECODE BY HAND...
  14912.     LNOUT(LO)=LNIN(LI)
  14913.     I1=ICHAR(LNIN(LI+1))
  14914.     I2=IMASK(I1,I192)
  14915. C    L2=L1.AND.L192
  14916.     I1=IMASK(I1,I63)
  14917. C    L1=L1.AND.L63
  14918. C DO MASKING TO GET BINARY COORDS
  14919.     ID1=I1
  14920.     I1=ICHAR(LNIN(LI+2))
  14921.     I1=IMASK(I1,I127)
  14922. C    L1=L1.AND.L127
  14923.     ID2=I2*2+I1
  14924. C NOW RELOCATE AND PUT BACK
  14925.     IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 510
  14926.     IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 510
  14927.     IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
  14928.     IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
  14929. C CLAMP RESULT TO MAX RANGES
  14930.     ID1=MAX0(ID1,1)
  14931.     ID2=MAX0(ID2,1)
  14932. C DO GENERAL REPACK IF ID1 OR ID2 ARE EXTENDED RANGE.
  14933.     IF(ID1.GT.60.OR.ID2.GT.301)GOTO 905
  14934. C leave 60, 301 literals here since this controls repacking
  14935. C    ID1=MIN0(60,ID1)
  14936. C    ID2=MIN0(301,ID2)
  14937. 510    CONTINUE
  14938. C RELOCATED, NOW REPACK AS NEW BINARY PATTERNS
  14939.     I1=ID1
  14940. C    L1=L1.AND.L63
  14941.     I1=IMASK(I1,I63)
  14942.     I2=ID2/2
  14943.     I2=IMASK(I2,I192)
  14944. C    L2=L2.AND.L192
  14945. C    L1=L1.OR.L2
  14946.     I1=I1+I2
  14947.     LNOUT(LO+1)=CHAR(I1)
  14948.     I2=ID2
  14949.     I2=IMASK(I2,I127)+128
  14950. C    L2=L2.AND.L127
  14951. C    L2=L2.OR.L128
  14952. C BE SURE AT LEAST 1 BIT IS SET
  14953.     LNOUT(LO+2)=CHAR(I2)
  14954.     LI=MIN0(109,LI+3)
  14955.     LO=MIN0(109,LO+3)    
  14956. C GO LOOK FOR MORE TO DECODE
  14957.     GOTO 300
  14958. 905    CONTINUE
  14959. C HERE SET UP FOR REENTRY INTO "NORMAL" DECODE
  14960.     LSTC=MIN0(109,LI+3)
  14961.     GOTO 906
  14962.     END
  14963. c -h- rnd.for    Tue Sep  2 10:58:55 1986    
  14964.     FUNCTION RND(DUM)
  14965. C GENERATE RANDOM NUMBER BY LINEAR CONGRUENCE IN BIG
  14966. C INTEGERS.
  14967.     REAL*4 R
  14968.     INTEGER*4 DUM
  14969.     INTEGER*4 I,II
  14970.     LOGICAL*4 L,LMSK
  14971.     REAL*8 XX
  14972.     EQUIVALENCE(I,L),(II,LMSK)
  14973.     I=DUM
  14974.     XX=I
  14975.     XX=XX*214013.0D0+2531011.0D0
  14976.     IF(XX.LT.0.)XX=1.0D0-XX
  14977.     XX=DMOD(XX,16777216.0D0)
  14978.     I=IDINT(XX)
  14979. C    I=I*214013+2531011
  14980. C USE MASKING TO ZOT THIS INTO NORMAL RANGE
  14981. C JUST USE MODULO...
  14982.     IF(I.LT.0)I=1-I
  14983.     IF(I.LT.0)I=0
  14984.     I=MOD(I,16777215)
  14985.     DUM=I
  14986. C RETURN RANDOM BETWEEN 0 AND 1.0
  14987. C PERIOD OF 2**24 MAX
  14988.     XX=I
  14989.     XX=XX/16777216.0
  14990.     R=SNGL(XX)
  14991.     RND=R
  14992.     RETURN
  14993.     END
  14994. c -h- rvboo.for    Tue Sep  2 10:58:55 1986    
  14995.     SUBROUTINE RVBOO(RETV,ID1,ID2)
  14996. C THIS ROUTINE ONLY COPIES ID1,ID2 INTO RETV ARRAY TO AVOID SOME
  14997. C BYTE-INTEGER CONVERSION PROBLEMS. THIS PACKING IS USED TO
  14998. C ACCESS VARIABLE LOCATION LATER.
  14999.     InTeGer*4 RETV,ID1,ID2
  15000.     DIMENSION RETV(2)
  15001.     RETV(1)=ID1
  15002.     RETV(2)=ID2
  15003.     RETURN
  15004.     END
  15005. c -h- scmp.for    Tue Sep  2 10:58:55 1986    
  15006.     SUBROUTINE SCMP(LINA,LINB,LENM,ICODE)
  15007.     DIMENSION LINA(1),LINB(1)
  15008.     CHARACTER*1 LINA,LINB
  15009.     ICODE=1
  15010.     DO 1 N=1,LENM
  15011.     IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
  15012. C ALLOW _ TO BE A WILDCARD.
  15013.     IF(LINA(N).EQ.'_'.OR.LINB(N).EQ.'_')GOTO 1
  15014.     IF(LINA(N).NE.LINB(N))ICODE=0
  15015.     IF(ICODE.NE.1)GOTO 2
  15016. 1    CONTINUE
  15017. 2    CONTINUE
  15018.     RETURN
  15019.     END
  15020. c -h- sed.for    Tue Sep  2 10:58:55 1986    
  15021.     SUBROUTINE SED(LCMD,LIN,LWRK,ARGSTR,XAC,LENGTH)
  15022.     CHARACTER*1 LIN(1),LWRK(1),ARGSTR(52,4)
  15023.     CHARACTER*1 LCMD(1),LSU(10)
  15024.     EXTERNAL INDX
  15025.     CHARACTER*10 LSU10
  15026.     EQUIVALENCE (LSU10(1:10),LSU(1))
  15027.     INTEGER*4 III
  15028.     REAL*8 XAC
  15029. C
  15030. C OPERATION:
  15031. C EDIT LIN TO LWRK, WITH LENGTH VARIABLE HOLDING INPUT
  15032. C LENGTH IN CHARACTERS. LCMD HOLDS COMMAND LINE, WHICH
  15033. C ULTIMATELY GETS EDITED STRING COPIED BACK INTO IT.
  15034. C
  15035. C EDITS:
  15036. C  CHARACTER AT IDELIM IS DELIMITER. REPLACE STRING IN 1ST
  15037. C INTERVAL BETWEEN DELIMITERS WITH SECOND.
  15038. C  HOWEVER:
  15039. C  &1 TO &4 GET CONTENTS (UP TO NULL) OF ARGSTR(X,1) TO (X,4)
  15040. C
  15041. C  &5 RETURNS XAC VALUE CONVERTED TO DECIMAL INTEGER AND
  15042. C  PRINTED.
  15043. C  &6 RETURNS XAC VALUE CONVERTED TO ASCII CODE (1 BYTE) AND
  15044. C  INSERTED.
  15045. C XAC ENTERS WITH CONTENTS OF ACCUMULATOR Z (TO AVOID TOO MUCH
  15046. C DIFFICULTY IN USING IT OWING TO THE UBIQUITY OF USE OF %).
  15047. C    WE ENTER JUST POINTING AT THE COMMAND LINE AFTER THE ENTER
  15048. C AND ITS SPACE. ASSUME 1ST CHARACTER IS OUR DELIMITER.
  15049.     DO 335 IV=1,80
  15050. 335    LWRK(IV)=Char(0)
  15051.     IDELIM=ICHAR(LCMD(1))
  15052.     ID2=INDX(LCMD(2),IDELIM)
  15053.     IF(ID2.GE.LENGTH)GOTO 100
  15054. C NOW HAVE 1ST STRING, OF NONZERO LENGTH
  15055. C FIND SECOND STRING NOW. EITHER MAY BE OF 0 LENGTH BUT
  15056. C BOTH MUST BE DEFINED BY A DELIMITER.
  15057.     ID3=INDX(LCMD(2+ID2),IDELIM)
  15058.     IF(ID3.GE.LENGTH)GOTO 100
  15059. C WELL, WE GOT IT SOMEHOW. NOW TRY AND EDIT THE JUNK IN.
  15060. C (NOTE WE WANT TO FILL ALL OF LENGTH)
  15061.     INLIN=1
  15062.     INWRK=1
  15063.     IVV=ID3+ID2+2
  15064.     DO 336 IV=IVV,LENGTH
  15065. 336    LCMD(IV)=Char(0)
  15066.     LSA=ID2-1
  15067.     LSB=ID3-1
  15068.     LSSB=2+ID2
  15069.     LZR=0
  15070.     DO 1 N=1,LENGTH
  15071.     IF(LSA.GT.0)GOTO 350
  15072. C ZERO LENGTH INITIAL STRING, SO ASSUME HE WANTS TO APPEND TO
  15073. C EXISTING STRING AT THE END.
  15074. C (HANDY FOR ADDING TO FORMULAE OR THE LIKE.)
  15075.     IF(Ichar(LIN(N)).EQ.0)GOTO 351
  15076. C JUST COPY THE INPUT FIRST AND GO OFF
  15077.     GOTO 2
  15078. 351    CONTINUE
  15079. C HERE WE HAVE THE TERMINAL NULL
  15080.     LZR=LZR+1
  15081. C ALLOW US TO PRETEND FOR ONCE THAT WE GOT A MATCH
  15082.     IF(LZR.EQ.1)GOTO 222
  15083.     GOTO 1
  15084. 350    CONTINUE
  15085.     IF(Ichar(LIN(INLIN)).EQ.0)GOTO 1
  15086.     CALL SSCMP(LIN(INLIN),LCMD(2),LSA,ICOD)
  15087.     IF(ICOD.EQ.0)GOTO 2
  15088. C HERE HAVE TO SUBSTITUTE
  15089. C PASS STRING TO SUBSTITUTE ON INPUT LINE FIRST.
  15090. 222    CONTINUE
  15091.     INLIN=INLIN+LSA
  15092. C ALLOW ZERO LENGTH SUBSTITUTE CHARACTER
  15093.     IF(LSB.LE.0)GOTO 1
  15094. C    DO 6 M=1,LSB
  15095.     M=1
  15096. 106    CONTINUE
  15097.     IF(LCMD(LSSB+M-1).EQ.'&')GOTO 7
  15098. 8    CONTINUE
  15099. C JUST COPY ONE CHARACTER OF THE SUBSTITUTE STRING IN HERE.
  15100.     LWRK(INWRK)=LCMD(LSSB+M-1)
  15101.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15102.     GOTO 6
  15103. 7    CONTINUE
  15104. C HANDLE & FORMS
  15105.     IF(LCMD(LSSB+M).LT.'1'.OR.LCMD(LSSB+M).GT.'6')GOTO 8
  15106. C REQUIRE ALL FORMS TO BE &1 THRU &6 TO BE DEALT WITH HERE.
  15107.     M=M+1
  15108.     IF(LCMD(LSSB+M-1).GT.'4')GOTO 10
  15109. C HERE JUST HANDLE ARGSTR SUBSTITUTIONS.
  15110.     II=ICHAR(LCMD(LSSB+M-1))
  15111.     II=II-48
  15112. C II IS NOW THE INDEX.
  15113.     DO 11 MM=1,52
  15114.     LWRK(INWRK)=ARGSTR(MM,II)
  15115.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15116.     IF(ARGSTR(MM,II).EQ.0)GOTO 12
  15117. 11    CONTINUE
  15118. 12    CONTINUE
  15119.     M=M+1
  15120. C PASS THE NUMBER OF THE &NUMBER FORM
  15121.     GOTO 6
  15122. 10    CONTINUE
  15123. C HANDLE ZAC FORMS
  15124.     M=M+1
  15125. C PASS THE DIGIT
  15126.     IF(LCMD(LSSB+M-2).EQ.'5')GOTO 14
  15127. C FILL IN ZAC AS AN INTEGER
  15128.     II=32
  15129.     IF(XAC.GE.1.AND.XAC.LT.256.)II=XAC
  15130. C ONLY HANDLE CONVERSION IF LEGAL
  15131.     LWRK(INWRK)=CHAR(II)
  15132.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15133.     GOTO 6
  15134. 14    CONTINUE
  15135. C HANDLE NUMERIC CONVERSION HERE
  15136.     LSU(1)=0
  15137.     III=0
  15138.     IF(DABS(XAC).LT.9999999.)III=IDINT(XAC)
  15139.     WRITE(LSU10(1:10),15,ERR=22)III
  15140. C    ENCODE(10,15,LSU,ERR=22)III
  15141. 15    FORMAT(I9)
  15142. 22    DO 16 MK=1,10
  15143.     IF(Ichar(LSU(MK)).EQ.0)GOTO 6
  15144.     IF(LSU(MK).EQ.' ')GOTO 16
  15145.     LWRK(INWRK)=LSU(MK)
  15146.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15147. 16    CONTINUE
  15148. 6    CONTINUE
  15149.     M=M+1
  15150.     IF(M.LE.LSB)GOTO 106
  15151.     GOTO 1
  15152. 2    CONTINUE
  15153. C HERE JUST ANOTHER CHARACTER TO MOVE, DO THE MOVE.
  15154.     LWRK(INWRK)=LIN(INLIN)
  15155.     IF(INLIN.LT.LENGTH)INLIN=INLIN+1
  15156.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15157. 1    CONTINUE
  15158. C COPY BACK OUT TO CMDLIN AFTER FIXUP
  15159.     IF(INWRK.GE.LENGTH)GOTO 3
  15160.     DO 4 N=INWRK,LENGTH
  15161. 4    LWRK(N)=0
  15162. 3    CONTINUE
  15163. C REPLACE COMMAND LINE WITH EDITED STRING FOR ENTRY NOW.
  15164.     DO 5 N=1,LENGTH
  15165. 5    LCMD(N)=LWRK(N)
  15166. 100    CONTINUE
  15167.     RETURN
  15168.     END
  15169. c -h- sign.for    Tue Sep  2 10:58:55 1986    
  15170.     REAL *8 FUNCTION SIGN(VAR)
  15171.     REAL*8 VAR
  15172. C ALWAYS RETURN 1. OR -1. FOR THIS PROGRAM ... NEVER 0.
  15173.     SIGN=1.
  15174.     IF(VAR.LT.0.)SIGN=-1.
  15175.     RETURN
  15176.     END
  15177. c -h- slend.for    Tue Sep  2 10:58:55 1986    
  15178.     SUBROUTINE SLEND(RETCD)
  15179. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  15180. C ALL RIGHTS RESERVED
  15181. C 60=MAX REAL ROWS
  15182. C 301=MAX REAL COLS
  15183. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  15184. C VBLS AND TYPE DIMENSIONED 60,301
  15185. C **************************************************
  15186. C *                                                *
  15187. C *         SUBROUTINE   SLEND(RETCD)              *
  15188. C *                                                *
  15189. C **************************************************
  15190. C
  15191. C
  15192. C
  15193. C SETS VALUE OF LEND, POINTER TO LAST NON-BLANK CHARACTER
  15194. C IN LINE(80)
  15195. C
  15196. C
  15197. C
  15198. C
  15199. C RETCD VALUE       MEANING
  15200. C
  15201. C    1            NORMAL RETURN
  15202. C    2            ALL BLANKS
  15203. C
  15204. C
  15205. C
  15206. C   SLEND IS CALLED BY CALC
  15207. C
  15208. C VARIABLE    USE
  15209. C
  15210. C  BLANK      ' '
  15211. C    I        INDEXES CHARACTERS IN LINE(80).
  15212. C  LEND       UPON EXIT, POINTS TO THE LAST NON-
  15213. C             BLANK IN LINE(80).
  15214. C  LINE(80)   HOLDS COMMAND LINE.
  15215. C  RETCD      RETURN CODE.  1=NORMAL, 2=ALL BLANKS
  15216. C
  15217. C
  15218. C
  15219. C    SUBROUTINE SLEND(RETCD)
  15220.     InTeGer*4 LEVEL,NONBLK,LEND
  15221.     InTeGer*4 VIEWSW,BASED,RETCD
  15222. C
  15223.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  15224.     CHARACTER*1 LINE(80)
  15225. C
  15226.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  15227.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  15228. C
  15229. C
  15230. C
  15231. C
  15232.     RETCD=1
  15233.     DO 100 I=1,80
  15234.     IF(LINE(81-I).NE.BLANK)GO TO 200
  15235. 100    CONTINUE
  15236.     RETCD=2
  15237.     RETURN
  15238. 200    LEND=81-I
  15239.     RETURN
  15240.     END
  15241. c -h- sscmp.for    Tue Sep  2 10:58:55 1986    
  15242.     SUBROUTINE SSCMP(LINA,LINB,LENM,ICODE)
  15243.     DIMENSION LINA(1),LINB(1)
  15244.     CHARACTER*1 LINA,LINB
  15245.     ICODE=1
  15246.     DO 1 N=1,LENM
  15247. c    IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
  15248.     IF(ICHAR(LINA(N)).NE.ICHAR(LINB(N)))ICODE=0
  15249.     IF(ICODE.NE.1)GOTO 2
  15250. 1    CONTINUE
  15251. 2    CONTINUE
  15252.     RETURN
  15253.     END
  15254. c -h- sstr.for    Tue Sep  2 10:58:55 1986    
  15255.     SUBROUTINE SSTR(CMDLIN,LA,N,LE,FORM)
  15256.     CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
  15257.     InTeGer*4 LA,N,LE
  15258.     InTeGer*4 VLEN(9),TYPE(1,1)
  15259.     CHARACTER*1 AVBLS(20,27)
  15260.     REAL*8 XVBLS(1,1),XX,VP,TMP
  15261.     COMMON/V/TYPE,AVBLS,XVBLS,VLEN
  15262.     NI=N
  15263. C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
  15264. C MUST PASS _@ CHARS TO GET VARIABLE
  15265.     LAA=LA+2
  15266.     LEE=LE
  15267.     CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
  15268.     IF(IVLD.LE.0)GOTO 990
  15269. C    XX=XVBLS(I1,I2)
  15270.     CALL XVBLGT(I1,I2,XX)
  15271.     VP=128.D0**7
  15272.     DO 1 NN=1,8
  15273.     TMP=DINT(XX/VP)
  15274.     NBF(NN)=CHAR(IDINT(TMP))
  15275.     XX=XX-(VP*TMP)
  15276.     VP=DINT(VP/128.D0)
  15277.     IF(VP.EQ.0.0D0)VP=1.0D0
  15278. 1    CONTINUE
  15279. C NOW NBF HAS 8 BYTES OF DATA CORRESPONDING TO DE-HASHED
  15280. C STRING. COPY TO FORM.
  15281.     NL=NI
  15282.     DO 2 NN=1,8
  15283.     FORM(NL)=NBF(NN)
  15284.     IF(ICHAR(NBF(NN)).GE.32)NL=NL+1
  15285. 2    CONTINUE
  15286. C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
  15287. C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
  15288. C AND LSTC IS NEXT CHAR AFTER VARIABLE ON CMDLIN
  15289. C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
  15290. C AND MOVE CMDLIN DOWN.
  15291.     N=NL-1
  15292.     LA=LSTC-1
  15293.     CMDLIN(LA)=FORM(N)
  15294. C HOPE ALL'S WELL NOW...
  15295.     RETURN
  15296. 990    FORM(N)=CMDLIN(N)
  15297.     RETURN
  15298.     END
  15299. c -h- strcmp.for    Tue Sep  2 10:58:55 1986    
  15300.     SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
  15301. C COPYRIGHT (C) 1983 GLENN EVERHART
  15302. C ALL RIGHTS RESERVED
  15303. C 60=MAX REAL ROWS
  15304. C 301=MAX REAL COLS
  15305. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  15306. C VBLS AND TYPE DIMENSIONED 60,301
  15307. C **************************************************
  15308. C *                                                *
  15309. C *   SUBROUTINE STRCMP(NAME,LENGTH,RETCD)         *
  15310. C *                                                *
  15311. C **************************************************
  15312. C
  15313. C
  15314. C  STRCMP LOOKS PAST BLANKS FOR THE NAME HELD BY NAME(1),...,NAME(LENGTH)
  15315. C  THE RETURN CODE RETCD INDICATES SUCCESS OR FAILURE:
  15316. C
  15317. C    1=MATCH
  15318. C    2=FAILURE
  15319. C
  15320. C  UPON EXIT, COMMON VARIABLE NONBLK
  15321. C         IF SUCCESSFUL, POINTS TO ONE BEYOND THE LAST CHARACTER SCANNED
  15322. C                 FOR MATCH
  15323. C         IF FAILURE, UNCHANGED
  15324. C
  15325. C
  15326. C
  15327. C  MODIFICATION CLASSES: M2
  15328. C
  15329. C
  15330. C
  15331. C  STRCMP CALLS GETNNB TO GET THE NEXT NON-BLANK FROM LINE(80)
  15332. C
  15333. C  STRCMP IS CALLED BY CMND
  15334. C
  15335. C
  15336. C
  15337. C
  15338. C VARIABLE       USE
  15339. C
  15340. C   I2        INDEXES NAME(LENGTH).
  15341. C   IS        HOLDS VALUE OF NONBLANK IN CASE AN ERROR OCCURS
  15342. C             AND IT IS NECESSARY TO RESTORE THE VALUE.
  15343. C   LENGTH    HOLDS THE LENGTH OF VECTOR NAME.
  15344. C   NONBLK    POINTER FOR COMMAND LINE HELD BY LINE(80).
  15345. C   RETCD     HOLDS RETURN CODE.  1=MATCH,  2=FAILURE
  15346. C
  15347. C
  15348. C
  15349. C
  15350. C    SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
  15351.     InTeGer*4 LENGTH
  15352.     InTeGer*4 LEVEL,NONBLK,LEND
  15353.     InTeGer*4  RETCD,VIEWSW,BASED
  15354. C
  15355.     CHARACTER*1  LINE(80),NAME(LENGTH)
  15356.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  15357. C
  15358.     COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  15359.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  15360. C
  15361. C UPON ENTRANCE, NONBLK POINTS TO THE FIRST CHARACTER
  15362. C IN NAME, COMPARE LOOKS PAST THIS TO THE NEXT CHARACTER
  15363. C SINCE CMND HAS ALREADY IDENTIFIED THAT FIRST CHARACTER
  15364. C IN THE COMMAND NAME (AFTER THE ASTERISK).
  15365.     IS=NONBLK
  15366.     CALL GETNNB(IPT,RETCD)
  15367.     GO TO (10,999),RETCD
  15368. C ON EXIT NONBLK POINTS TO LAST CHARACTER IN NAME
  15369. C
  15370. C
  15371. 10    DO 100 I2=1,LENGTH
  15372.     CALL GETNNB(IPT,RETCD)
  15373.     GO TO (20,999),RETCD
  15374.     STOP 20
  15375. 20    NONBLK=IPT
  15376.     IF(NAME(I2).NE.LINE(NONBLK))GOTO 999
  15377. 100    CONTINUE
  15378.     RETCD=1
  15379.     RETURN
  15380. C
  15381. C
  15382. C NO MATCH
  15383. 999    RETCD=2
  15384. C IF ERROR, RESTORE VALUE OF NONBLK
  15385.     NONBLK=IS
  15386.     RETURN
  15387.     END
  15388. c -h- svbl.for    Tue Sep  2 10:58:55 1986    
  15389.     SUBROUTINE SVBL(CMDLIN,LA,N,LE,FORM)
  15390.     Include Aparms.Inc
  15391.     InTeGer*4 VLEN(9),TYPE(1,1)
  15392.     CHARACTER*1 AVBLS(20,27)
  15393.     REAL*8 XVBLS(1,1),XX,XY,xmr,xmc
  15394.     COMMON/V/TYPE,AVBLS,XVBLS,VLEN
  15395.     CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
  15396.     CHARACTER*3 NBF3
  15397.     EQUIVALENCE(NBF3(1:1),NBF(5))
  15398.     InTeGer*4 LA,N,LE,I1,I2,J1,J2
  15399.     NI=N
  15400.     xmr=Mrows
  15401.     xmc=Mcols
  15402. C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
  15403.     LAA=LA+2
  15404. C MUST PASS _# CHARS
  15405.     LEE=LE
  15406.     CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
  15407.     IF(IVLD.LE.0)GOTO 990
  15408.     LAA=LSTC+1
  15409. C ACCEPT ANY DELIMITER
  15410.     LEE=LE
  15411.     CALL VARSCN(CMDLIN,LAA,LEE,LSTC,J1,J2,IVLD)
  15412.     IF(IVLD.LE.0)GOTO 990
  15413. C    XX=XVBLS(I1,I2)
  15414.     CALL XVBLGT(I1,I2,XX)
  15415. C XX IS COL #
  15416. C    XY=XVBLS(J1,J2)-1.0
  15417.     CALL XVBLGT(J1,J2,XY)
  15418.     IF(XX.LE.(0.9D0).OR.XX.GT.XMR)GOTO 990
  15419.     IF(XY.LE.(0.9D0).OR.XY.GT.XMC)GOTO 990
  15420.     IC=XX
  15421.     CALL IN2AS(IC,NBF)
  15422.     IR=XY
  15423.     WRITE(NBF3(1:3),300)IR
  15424. C    ENCODE(3,300,NBF(5))IR
  15425. 300    FORMAT(I3)
  15426.     NL=NI
  15427. C FILL IN DECODED VARIABLE NAME, ZOTTING OUT EXTRA SPACES.
  15428.     DO 400 NN=1,7
  15429. C 47 IS ASCII VALUE FOR 0 CHARACTER
  15430. C ALPHAS ARE ALSO ALL HIGHER.
  15431.     IF(ICHAR(NBF(NN)).LE.40)GOTO 400
  15432.     FORM(NL)=NBF(NN)
  15433.     NL=NL+1
  15434. 400    CONTINUE
  15435. C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
  15436. C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
  15437. C AND LSTC IS NEXT CHAR AFTER 2ND VARIABLE ON CMDLIN
  15438. C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
  15439. C AND MOVE CMDLIN DOWN.
  15440.     N=NL
  15441.     LE=LE-LSTC+NL
  15442.     LA=LSTC
  15443. C    DO 401 M=N,LE
  15444. C    CMDLIN(M)=CMDLIN(M+LSTC-NL)
  15445. C401    CONTINUE
  15446. C HOPE ALL'S WELL NOW...
  15447.     RETURN
  15448. 990    CONTINUE
  15449.     FORM(N)=CMDLIN(N)
  15450.     RETURN
  15451.     END
  15452. c -h- swrt.for    Tue Sep  2 10:58:55 1986    
  15453. C
  15454. C SWRT - WRITE VARIABLE LENGTH STRING TO SCREEN WITHOUT
  15455. C RECORD TERMINATION.
  15456. C COPYRIGHT GLENN C EVERHART 1984
  15457. C ALL RIGHTS RESERVED
  15458. C *** Don't use for normal Amiga stuff, but have available in case
  15459. C *** it should be handy someplace...
  15460. C
  15461. C
  15462. ccc    SUBROUTINE SWRT(STRING,LENGTH)
  15463. ccc    CHARACTER*1 STRING(127)
  15464. ccc    INTEGER LENGTH
  15465. cccC DUMP OUT ALL WE CAN..
  15466. ccc    CHARACTER*9 SFM
  15467. ccc    CHARACTER*1 SFMX(9)
  15468. ccc    CHARACTER*3 SNM
  15469. ccc    EQUIVALENCE(SNM,SFMX(2))
  15470. ccc    EQUIVALENCE (SFMX(1),SFM)
  15471. cccC HERE ARE THE BUILT IN FORMATS. NOTE WE FILL IN THE
  15472. cccC REPEAT COUNT AT RUNTIME FOR THE TEXT TO BE WRITTEN.
  15473. cccC NOTE ALSO THAT THE 1ST CHAR IS A # SIGN TO SHOW UP PROBLEMS.
  15474. cccC FORMATS ARE (nnnA1,\)
  15475. cccC COMPRISING 13 CHARACTERS IN ALL.
  15476. ccc    DATA SFM/'(001A1,\)'/
  15477. cccC NOTE WE JUST FILL IN THE LENGTH AND WRITE TO SCREEN USING
  15478. cccC SFM AS A RUNTIME FORMAT.
  15479. cccC
  15480. ccc    IF(LENGTH.LE.0)RETURN
  15481. ccc    WRITE(SNM,1)LENGTH
  15482. ccc1    FORMAT(BZ,I3)
  15483. cccC WRITE ON UNIT 6 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
  15484. cccC (VIA EXPLICIT OPEN IN MAIN PROGRAM)
  15485. ccc    WRITE(11,SFM)(STRING(II),II=1,LENGTH)
  15486. ccc    RETURN
  15487. ccc    END
  15488.     subroutine vget(buf,len)
  15489.     character*1 buf(132),cbf(132)
  15490.     integer*4 len,ii,i
  15491. C Read buf up to len from console
  15492.     do 2 i=1,128
  15493.     cbf(i)=char(0)
  15494. 2    continue
  15495.     call getttl(cbf)
  15496. c    call cmdmun(cbf)
  15497.     ii=min0(len,132)
  15498.     ii=max0(len,1)
  15499. C reads console into large buffer, returns n chars of it.
  15500.     do 1 i=1,ii
  15501.     buf(i)=cbf(i)
  15502. 1    Continue
  15503.     return
  15504.     end
  15505.     subroutine vgeti(iii)
  15506. C get integer from command line
  15507.     integer*4 iii
  15508.     character*20 buf
  15509.     call vget(buf,20)
  15510.     read(buf,1000,err=999)iii
  15511. 1000    format(i7)
  15512.     return
  15513. 999    Continue
  15514.     iii=0
  15515.     return
  15516.     end
  15517.     SUBROUTINE VWRT(STRING,LENGTH)
  15518. C ***<<<< RDD COMMON START >>>***
  15519.     InTeGer*4 RRWACT,RCLACT
  15520. C    COMMON/RCLACT/RRWACT,RCLACT
  15521.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  15522.      1  IDOL7,IDOL8
  15523. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  15524. C     1  IDOL7,IDOL8
  15525.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  15526. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  15527.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15528. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15529. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  15530. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  15531.     InTeGer*4 KLVL
  15532. C    COMMON/KLVL/KLVL
  15533.     InTeGer*4 IOLVL,IGOLD
  15534. C    COMMON/IOLVL/IOLVL
  15535. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  15536. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  15537.     Integer*4 IDSPTP,Idol9
  15538.     integer*4 k3dfg,kcdelt,krdelt,kpag
  15539.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  15540.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  15541.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  15542.      3  k3dfg,kcdelt,krdelt,kpag
  15543. C ***<<< RDD COMMON END >>>***
  15544. C VWRT is like SWRT but writes to lun 11 window instead.
  15545.     CHARACTER*1 STRING(127)
  15546.     INTEGER LENGTH
  15547. C DUMP OUT ALL WE CAN..
  15548.     IF(LENGTH.LE.0)RETURN
  15549. C WRITE ON UNIT 11 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
  15550. C (VIA EXPLICIT OPEN IN MAIN PROGRAM)
  15551. c    REWIND 11
  15552. c    call uvt100(1,LLDSP,1)
  15553.     call swrt(string,length)
  15554. c    WRITE(11,777)(STRING(II),II=1,LENGTH)
  15555. c    REWIND 11
  15556. 777    format(1X,127A1)
  15557.     RETURN
  15558.     END
  15559.  
  15560. C *************** AnalyO.Ftn ##########################################
  15561. c -h- acini1.fnw    Fri Aug 22 12:55:08 1986    
  15562. C PORTACALC MAIN PROGRAM
  15563. C SPREAD SHEET DRIVER PROGRAM
  15564. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  15565. C ALL RIGHTS RESERVED
  15566. C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
  15567. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  15568. C SCREEN.
  15569.     SUBROUTINE INITA1(KMAP,KWID,ICODE)
  15570. C
  15571.     Include AParms.inc
  15572.     InTeGer*4 PRL(6)
  15573.         CHARACTER*1 NOWRAP ( 2 )
  15574.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  15575.     INTEGER*4 VNLT
  15576.     INTEGER IFCW
  15577. c    EXTERNAL LCWRQQ
  15578.     DIMENSION FORM(128),FVLD(1,1)
  15579. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  15580. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  15581. C SO INITIALLY IGNORE.
  15582. C ***<<<< RDD COMMON START >>>***
  15583.     InTeGer*4 RRWACT,RCLACT
  15584. C    COMMON/RCLACT/RRWACT,RCLACT
  15585.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  15586.      1  IDOL7,IDOL8
  15587. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  15588. C     1  IDOL7,IDOL8
  15589.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  15590. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  15591.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15592. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15593. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  15594. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  15595.     InTeGer*4 KLVL
  15596. C    COMMON/KLVL/KLVL
  15597.     InTeGer*4 IOLVL,IGOLD
  15598. C    COMMON/IOLVL/IOLVL
  15599. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  15600. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  15601.     Integer*4 IDSPTP,Idol9
  15602.     integer*4 k3dfg,kcdelt,krdelt,kpag
  15603.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  15604.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  15605.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  15606.      3  k3dfg,kcdelt,krdelt,kpag
  15607. C ***<<< RDD COMMON END >>>***
  15608. CCC    InTeGer*4 RRWACT,RCLACT
  15609. CCC    COMMON/RCLACT/RRWACT,RCLACT
  15610. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  15611. CCC     1  IDOL7,IDOL8
  15612. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  15613. CCC     1  IDOL7,IDOL8
  15614. CCC    InTeGer*4 LLCMD,LLDSP
  15615. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  15616. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  15617.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  15618.     COMMON/D2R/NRDSP,NCDSP
  15619. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15620. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15621. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  15622. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  15623.     CHARACTER*1 FORM2(4)
  15624. C ***<<< XVXTCD COMMON START >>>***
  15625.     CHARACTER*1 OARRY(100)
  15626.     InTeGer*4 OSWIT,OCNTR
  15627. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  15628. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  15629.     InTeGer*4 IPS1,IPS2,MODFLG
  15630. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  15631.        InTeGer*4 XTCFG,IPSET,XTNCNT
  15632.        CHARACTER*1 XTNCMD(80)
  15633. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  15634. C VARY FLAG ITERATION COUNT
  15635.     INTEGER KALKIT
  15636. C    COMMON/VARYIT/KALKIT
  15637.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  15638.     InTeGer*4 RCMODE,IRCE1,IRCE2
  15639. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  15640. C     1  IRCE2
  15641. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  15642. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  15643. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  15644. C RCFGX ON.
  15645. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  15646. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  15647. C  AND VM INHIBITS. (SETS TO 1).
  15648.     INTEGER*4 FH
  15649. C FILE HANDLE FOR CONSOLE I/O (RAW)
  15650. C    COMMON/CONSFH/FH
  15651.     CHARACTER*1 ARGSTR(52,4)
  15652. C    COMMON/ARGSTR/ARGSTR
  15653.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  15654.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  15655.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  15656.      3  IRCE2,FH,ARGSTR
  15657. C ***<<< XVXTCD COMMON END >>>***
  15658. CCC    InTeGer*4 OSWIT,OCNTR
  15659. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  15660. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  15661.     InTeGer*4 TYPE(1,1),VLEN(9)
  15662. CCC    InTeGer*4 KLVL
  15663. CCC    COMMON/KLVL/KLVL
  15664. CCC    InTeGer*4 IOLVL
  15665. CCC    COMMON/IOLVL/IOLVL
  15666. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  15667. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  15668.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  15669.     REAL*8 XXV(1,1)
  15670.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  15671.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  15672. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  15673.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  15674.     CHARACTER*12 CDVFMT
  15675.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  15676.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  15677.     COMMON/DEFVBX/DVFMT
  15678.     CHARACTER*1 NMSH(80)
  15679.     CHARACTER*80 NMSH80
  15680.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  15681.     COMMON/NMSH/NMSH
  15682. CCC    InTeGer*4 IPS1,IPS2,MODFLG
  15683. CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
  15684. CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
  15685. CCC       CHARACTER*1 XTNCMD(80)
  15686. CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  15687. C VARY FLAG ITERATION COUNT
  15688. CCC    INTEGER KALKIT
  15689. CCC    COMMON/VARYIT/KALKIT
  15690. CCC    InTeGer*4 FORMFG,RCFGX,PZAP
  15691. CCC    InTeGer*4 RCONE,RCMODE,IRCE1,IRCE2
  15692. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  15693. CCC     1  IRCE1,IRCE2
  15694. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  15695. C RCFGX FLAGS WHETHER TO DO AUTO RECALC
  15696. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED
  15697.     InTeGer*4 CWIDS(20)
  15698. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY.
  15699.     INTEGER*4 I4TMP
  15700. C ***<<< NULETC COMMON START >>>***
  15701.     InTeGer*4 ICREF,IRREF
  15702. C    COMMON/MIRROR/ICREF,IRREF
  15703.     InTeGer*4 MODPUB,LIMODE
  15704. C    COMMON/MODPUB/MODPUB,LIMODE
  15705.     InTeGer*4 KLKC,KLKR
  15706.     REAL*8 AACP,AACQ
  15707. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  15708.     InTeGer*4 NCEL,NXINI
  15709. C    COMMON/NCEL/NCEL,NXINI
  15710.     CHARACTER*1 NAMARY(20,MRows)
  15711. C    COMMON/NMNMNM/NAMARY
  15712.     InTeGer*4 NULAST,LFVD
  15713. C    COMMON/NULXXX/NULAST,LFVD
  15714.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  15715.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  15716. C ***<<< NULETC COMMON END >>>***
  15717. CCC    InTeGer*4 ICREF,IRREF
  15718. CCC    COMMON/MIRROR/ICREF,IRREF
  15719. C SETS NUMBER OF COLS TO ADD ON ROW OVERFLOW, ROWS TO ADD ON COL OVERFLOW
  15720. C FOR CELL ALIASING.
  15721.     REAL*8 DVS(20,75)
  15722.     COMMON /FVLDC/FVLD
  15723. C FOLLOWING SUPPORT VVARY OVERLAY:
  15724.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  15725.     LOGICAL*4 LEXIST
  15726.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  15727.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  15728.     COMMON/DSPCMN/DVS,CWIDS
  15729.     CHARACTER*1 CHR
  15730.     character*20 fwt
  15731.     EQUIVALENCE(FWT(1:1),CHR)
  15732. C DISABLE FLOATING EXCEPTIONS
  15733. C    CALL LCWRQQ(IFCW)
  15734. C (MOVED LCWRQQ CALL TO MAIN)
  15735.     IDOL7=1
  15736. C ENABLE SCROLLING INITIALLY
  15737. C ZERO "SAVED DISPLAY VALUES" FIRST...
  15738.     DO 35 N=1,75
  15739.     DO 35 NN=1,20
  15740. 35    DVS(NN,N)=0.
  15741.     MODFLG=1
  15742. C INITIALLY IN NON ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
  15743. C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
  15744. C SETUP INITIAL DISPLAY LIMITS ACTUALLY USED.
  15745.     RRWACT=1
  15746.     K3DFG=0
  15747.     KCDELT=0
  15748.     KRDELT=0
  15749.     RCLACT=1
  15750.     IOLVL=11
  15751. c Set rather small sheet to allow for use on non-interlace screen
  15752. c initially
  15753.     DRWV=7
  15754.     DCLV=17
  15755.     LLCMD=20
  15756.     LLDSP=21
  15757.     If(Idsptp.ne.1)goto 4866
  15758.     DRWV=7
  15759.     DCLV=42
  15760.     LLCMD=45
  15761.     LLDSP=46
  15762. c Interlace dimensions for main window display
  15763. 4866    Continue
  15764.     ICREF=10
  15765.     IRREF=50
  15766. C SET INCREMENTS TO 1/6 OF TOTAL FOR STARTERS.
  15767.     KLVL=1
  15768.     KALKIT=0
  15769.     IRCE1=0
  15770.     IRCE2=0
  15771.     RCMODE=2
  15772.     ICODE=0
  15773.     idol3=0
  15774.     idol4=0
  15775.     idol5=20000
  15776.     idol6=20000
  15777.     Idol8=1
  15778.     RCFGX=0
  15779.     FORMFG=0
  15780. C      CALL GETADR ( PRL, NOWRAP )
  15781.       PRL ( 2 ) = 2
  15782. c    OPEN(6,FILE='CON:',STATUS='NEW',FORM='FORMATTED')
  15783.     If(Idsptp.eq.1)goto 4867
  15784. c Non interlace (640 x 200) screen
  15785. c    OPEN(11,FILE='CON:20/169/550/30/Analy Command Inputs',
  15786. c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
  15787.     Goto 4868
  15788. 4867    Continue
  15789. c Interlace
  15790. c    OPEN(11,FILE='CON:20/369/550/30/Analy Command Inputs',
  15791. c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
  15792. 4868    Continue
  15793. c    OPEN(18,FILE='CON:20/210/450/30/Analy Cmd Prompts',
  15794. c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
  15795. C LOOK FOR 'ACINIT.PRM' INITIALIZER FILE. IF ONE FOUND, READ IT.
  15796. C IF NOT, ASK AT CONSOLE FOR SINGLE/DBL PRECISION AND INITIAL VIDEO MODE
  15797.     IVV=11
  15798. C SET UP AS THOUGH WE HAD AN @ACINIT.PRM AT STARTUP AND
  15799. C ALLOW IT TO GO THRU NORMALLY...
  15800.     INQUIRE(FILE='ACINIT.PRM',EXIST=LEXIST)
  15801.     IF(.NOT.LEXIST)GOTO 6003
  15802.     OPEN(3,FILE='ACINIT.PRM',STATUS='OLD',FORM='FORMATTED')
  15803. C    CALL RASSIG(3,'ACINIT.PRM')
  15804.     IVV=3
  15805.     IOLVL=3
  15806.     GOTO 6403
  15807. 6003    CONTINUE
  15808. C    OPEN(5,FILE='CON:',STATUS='OLD',FORM='FORMATTED')
  15809. C OPEN EITHER CONSOLE OR INIT FILE AT FIRST...
  15810. 6403    CONTINUE
  15811. 6005    FORMAT(80A1)
  15812. C For AMIGA always use "BIOS MODE" so we can have special windowing
  15813. C code in place of the Fortran I/O. Fortran console I/O will be done
  15814. C using LUN 11 in a CON: window, but most normal spreadsheet
  15815. C operations will take place in a special window over which we will have
  15816. C finer grained control...
  15817. C
  15818.     CALL SWSET(1)
  15819.     MODFLG=1
  15820. 6008    CONTINUE
  15821. C SETS UP FOR USING ROM BIOS DIRECTLY FOR EVERYTHING...
  15822. C COULD THEN USE E.G. NEWKEY TO DO KEYBOARD CMDS.
  15823.     GOTO 6002
  15824. 6006    CONTINUE
  15825. C ERROR ON INPUT HERE... JUST FORGET IT.
  15826.     CLOSE(3)
  15827.     IOLVL=11
  15828. C MAKE SURE LUN 5 HAS A CONSOLE FILE OPEN.
  15829. c    CLOSE(11)
  15830. c    OPEN(11,FILE='CON:0/50/200/60/Analy Command',
  15831. c     1  STATUS='OLD',FORM='FORMATTED')
  15832. 6002    CALL UVT100(18,0,0)
  15833. C PERFORM SYSTEM DEPENDENT INITIALIZATION for terminal. (none here really)
  15834. c may later read + write auxkpd.txt to set up escape seqs.
  15835.     CALL TTYINI
  15836. C
  15837. C SET UP THE SCREEN (ERASE, ETC.)
  15838. c erase screen first
  15839.     CALL UVT100(1,5,10)
  15840.     CALL UVT100(11,2,0)
  15841. c position cursor to r5c10
  15842.     CALL UVT100(1,5,10)
  15843. C ZERO THE VARIABLES TO START OFF WITH.
  15844.     DO 2070 KK=1,20
  15845.     DO 2070 KKK=1,27
  15846. 2070    AVBLS(KK,KKK)=0
  15847. C SET UP WORK ARRAY BITMAP
  15848.     CALL WRKFIL(1,FORM,2)
  15849. c set reverse video title
  15850.     CALL UVT100(13,7,0)
  15851.     CALL SWRT('AnalytiCalc-68K',15)
  15852.     CALL UVT100(1,6,12)
  15853.     CALL SWRT('V25-03A',7)
  15854.     CALL UVT100(13,0,0)
  15855.     CALL UVT100(1,8,3)
  15856.     CALL SWRT(' ...The Analyst`s Tool',22)
  15857.     CALL UVT100(1,9,5)
  15858. C original name was VisiKluge, then ViziKluge, then PortaCalc, then 
  15859. C AnalyCalc, then AnalytiCalc.
  15860.     CALL SWRT('Copyright (C) 1982-1990 Glenn & Mary Everhart',45)
  15861.     CALL UVT100(1,10,1)
  15862. C ALLOW SPACE FOR ASKING FOR MONEY LATER VIA PATCH IF DESIRED.
  15863.     CALL SWRT('If you use this program please send $10.00 donation',
  15864.      1  51)
  15865.     CALL UVT100(1,11,1)
  15866.     CALL SWRT('to Glenn Everhart, 25 Sleigh Ride, Glen Mills PA. ',
  15867.      1  50)
  15868.     CALL UVT100(1,12,1)
  15869.     CALL SWRT('19342. May be copied for others',
  15870.      1  31)
  15871. C NOW GET ON WITH USEFUL WORK.
  15872.       PRL ( 2 ) = 1
  15873.       PRL ( 3 ) = 0
  15874. c set ansi mode...
  15875.       CALL UVT100 ( 18 ,0,0)
  15876.     Call uvt100(1,13,1)
  15877.     KWID=10
  15878.     KMAP=1
  15879.     RETURN
  15880.     END
  15881. c -h- acini2.for    Fri Aug 22 12:55:25 1986    
  15882. C PORTACALC MAIN PROGRAM
  15883. C SPREAD SHEET DRIVER PROGRAM
  15884. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  15885. C ALL RIGHTS RESERVED
  15886. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  15887. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  15888. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  15889. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  15890. C FROM THE DISK BASED FILE HERE.
  15891.     SUBROUTINE INITA2(KMAP,KWID,ICODE,IKONS)
  15892. C
  15893.     Include AParms.inc
  15894.     InTeGer*4 PRL(6)
  15895.         CHARACTER*1 NOWRAP ( 2 )
  15896.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  15897.     INTEGER*4 VNLT
  15898.     INTEGER IFCW
  15899. C    EXTERNAL LCWRQQ
  15900.     DIMENSION FORM(128),FVLD(1,1)
  15901. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  15902. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  15903. C SO INITIALLY IGNORE.
  15904. C
  15905. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  15906. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  15907. C ***<<<< RDD COMMON START >>>***
  15908.     InTeGer*4 RRWACT,RCLACT
  15909. C    COMMON/RCLACT/RRWACT,RCLACT
  15910.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  15911.      1  IDOL7,IDOL8
  15912. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  15913. C     1  IDOL7,IDOL8
  15914.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  15915. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  15916.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15917. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15918. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  15919. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  15920.     InTeGer*4 KLVL
  15921. C    COMMON/KLVL/KLVL
  15922.     InTeGer*4 IOLVL,IGOLD
  15923. C    COMMON/IOLVL/IOLVL
  15924. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  15925. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  15926.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  15927.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  15928.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  15929.      3  k3dfg,kcdelt,krdelt,kpag
  15930. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  15931. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  15932. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  15933. C ***<<< RDD COMMON END >>>***
  15934. CCC    InTeGer*4 RRWACT,RCLACT
  15935. CCC    COMMON/RCLACT/RRWACT,RCLACT
  15936. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  15937. CCC     1  IDOL7,IDOL8
  15938. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  15939. CCC     1  IDOL7,IDOL8
  15940. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  15941. CCC    InTeGer*4 LLCMD,LLDSP
  15942. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  15943.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  15944.     COMMON/D2R/NRDSP,NCDSP
  15945. C ***<<< NULETC COMMON START >>>***
  15946.     InTeGer*4 ICREF,IRREF
  15947. C    COMMON/MIRROR/ICREF,IRREF
  15948.     InTeGer*4 MODPUB,LIMODE
  15949. C    COMMON/MODPUB/MODPUB,LIMODE
  15950.     InTeGer*4 KLKC,KLKR
  15951.     REAL*8 AACP,AACQ
  15952. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  15953.     InTeGer*4 NCEL,NXINI
  15954. C    COMMON/NCEL/NCEL,NXINI
  15955.     CHARACTER*1 NAMARY(20,MRows)
  15956. C    COMMON/NMNMNM/NAMARY
  15957.     InTeGer*4 NULAST,LFVD
  15958. C    COMMON/NULXXX/NULAST,LFVD
  15959.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  15960.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  15961. C ***<<< NULETC COMMON END >>>***
  15962. CCC    InTeGer*4 ICREF,IRREF
  15963. CCC    COMMON/MIRROR/ICREF,IRREF
  15964. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15965. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15966. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  15967. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  15968.     CHARACTER*1 FORM2(4)
  15969. C ***<<< XVXTCD COMMON START >>>***
  15970.     CHARACTER*1 OARRY(100)
  15971.     InTeGer*4 OSWIT,OCNTR
  15972. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  15973. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  15974.     InTeGer*4 IPS1,IPS2,MODFLG
  15975. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  15976.        InTeGer*4 XTCFG,IPSET,XTNCNT
  15977.        CHARACTER*1 XTNCMD(80)
  15978. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  15979. C VARY FLAG ITERATION COUNT
  15980.     INTEGER KALKIT
  15981. C    COMMON/VARYIT/KALKIT
  15982.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  15983.     InTeGer*4 RCMODE,IRCE1,IRCE2
  15984. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  15985. C     1  IRCE2
  15986. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  15987. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  15988. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  15989. C RCFGX ON.
  15990. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  15991. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  15992. C  AND VM INHIBITS. (SETS TO 1).
  15993.     INTEGER*4 FH
  15994. C FILE HANDLE FOR CONSOLE I/O (RAW)
  15995. C    COMMON/CONSFH/FH
  15996.     CHARACTER*1 ARGSTR(52,4)
  15997. C    COMMON/ARGSTR/ARGSTR
  15998.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  15999.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  16000.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16001.      3  IRCE2,FH,ARGSTR
  16002. C ***<<< XVXTCD COMMON END >>>***
  16003. CCC    InTeGer*4 OSWIT,OCNTR
  16004. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  16005. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16006.     InTeGer*4 TYPE(1,1),VLEN(9)
  16007. CCC    InTeGer*4 KLVL
  16008. CCC    COMMON/KLVL/KLVL
  16009. CCC    InTeGer*4 IOLVL
  16010. CCC    COMMON/IOLVL/IOLVL
  16011. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16012. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16013.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  16014.     REAL*8 XXV(1,1)
  16015.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  16016.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  16017. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  16018.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  16019.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  16020.     CHARACTER*12 CDVFMT
  16021.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  16022.     COMMON/DEFVBX/DVFMT
  16023.     CHARACTER*1 NMSH(80)
  16024.     CHARACTER*80 NMSH80
  16025.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  16026.     COMMON/NMSH/NMSH
  16027. CCC    InTeGer*4 IPS1,IPS2,MODFLG
  16028. CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16029. CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
  16030. CCC       CHARACTER*1 XTNCMD(80)
  16031. CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16032. C VARY FLAG ITERATION COUNT
  16033. CCC    INTEGER KALKIT
  16034. CCC    COMMON/VARYIT/KALKIT
  16035. CCC    InTeGer*4 FORMFG,RCFGX,PZAP
  16036. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP
  16037. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16038. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  16039. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  16040. C RCFGX ON.
  16041. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  16042. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  16043. C  AND VM INHIBITS. (SETS TO 1).
  16044. C
  16045. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  16046. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  16047. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  16048. C DISPLAY ACTUALLY USED FOR SCREEN.
  16049.     InTeGer*4 CWIDS(20)
  16050. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  16051. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  16052. C AS 20 NOT 75.
  16053.     INTEGER*4 I4TMP
  16054.     REAL*8 DVS(20,75)
  16055.     COMMON /FVLDC/FVLD
  16056. C FOLLOWING SUPPORT VVARY OVERLAY:
  16057.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  16058.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  16059.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  16060. C BITMAP
  16061. C    CHARACTER*1 IBITMP
  16062. C    DIMENSION IBITMP(2258)
  16063. C    COMMON/INITD/IBITMP
  16064. C    CHARACTER*1 DFMTS(10,20,75)
  16065. C 10 CHARACTERS PER ENTRY.
  16066.     COMMON/DSPCMN/DVS,CWIDS
  16067.     character*35 fwt
  16068. C ***<<< KLSTO COMMON START >>>***
  16069.     InTeGer*4 DLFG
  16070. C    COMMON/DLFG/DLFG
  16071.     InTeGer*4 KDRW,KDCL
  16072. C    COMMON/DOT/KDRW,KDCL
  16073.     InTeGer*4 DTRENA
  16074. C    COMMON/DTRCMN/DTRENA
  16075.     REAL*8 EP,PV,FV
  16076.     DIMENSION EP(20)
  16077.     INTEGER*4 KIRR
  16078. C    COMMON/ERNPER/EP,PV,FV,KIRR
  16079.     InTeGer*4 LASTOP
  16080. C    COMMON/ERROR/LASTOP
  16081.     CHARACTER*1 FMTDAT(9,76)
  16082. C    COMMON/FMTBFR/FMTDAT
  16083.     CHARACTER*1 EDNAM(16)
  16084. C    COMMON/EDNAM/EDNAM
  16085.     InTeGer*4 MFID(2),MFMOD(2)
  16086. C    COMMON/FRM/MFID,MFMOD
  16087.     InTeGer*4 JMVFG,JMVOLD
  16088. C    COMMON/FUBAR/JMVFG,JMVOLD
  16089.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  16090.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  16091. C ***<<< KLSTO COMMON END >>>***
  16092. CCC    CHARACTER*1 EDNAM(16)
  16093. CCC    COMMON/EDNAM/EDNAM
  16094.     CHARACTER*1 EDNINI(4)
  16095.     DATA EDNINI/'E','D','I','T'/
  16096. C    DATA NOWRAP / "24,0 /
  16097. C
  16098.     DO 2900 III=1,16
  16099. 2900    EDNAM(III)=' '
  16100.     DO 2901 III=1,4
  16101. 2901    EDNAM(III)=EDNINI(III)
  16102.     IF(IKONS.EQ.0)GOTO 3000
  16103. 3002    CONTINUE
  16104.     CALL UVT100(1,1,1)
  16105.     CALL VWRT('Alter Widths or Mapping Y/N:',28)
  16106.     ILL=IOLVL
  16107. C    IF(ILL.EQ.5)ILL=0
  16108.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16109.     if(ill.eq.11)call vget(form,4)
  16110.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3000
  16111.     CALL VWRT('Enter NEW Global Column Width 1-120:',36)
  16112. C ALTER MAPPING DESIRED
  16113.     if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)KWID
  16114.     if(ill.eq.11)call vgeti(kwid)
  16115. 3004    FORMAT(I3)
  16116.     IF(KWID.LT.1.OR.KWID.GT.120)KWID=10
  16117.     CALL VWRT('Enter length of display in lines (nominally 24):',48)
  16118.     if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)III
  16119.     if(ill.eq.11)call vgeti(iii)
  16120.     IF(III.LE.4.OR.III.GT.999)III=24
  16121. C RESET DISPLAY SIZE IN S COMMAND QUESTIONS AS NEEDED.
  16122.     LLDSP=III
  16123.     LLCMD=III-1
  16124.     CALL VWRT('Change annotate editor from "EDIT" [Y/N]:',41)
  16125.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16126.     if(ill.eq.11)call vget(form,4)
  16127.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3031
  16128.     CALL VWRT('Give desired edit command:',26)
  16129.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)EDNAM
  16130.     if(ill.eq.11)call vget(ednam,16)
  16131.     EDNAM(16)=' '
  16132. C ENSURE THERE'S A SPACE AT END OF EDITOR NAME
  16133. 3031    CONTINUE
  16134.     CALL VWRT('Modify Extended Area Remap Y/N: ',31)
  16135.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16136.     if(ill.eq.11)call vget(form,4)
  16137.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3502
  16138.     CALL VWRT('# cols to move over on row overflow:',36)
  16139.     if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)ICREF
  16140.     if(ill.eq.11)call vgeti(icref)
  16141.     IF(ICREF.GT.MCols)ICREF=10
  16142.     IF(ICREF.LT.0)ICREF=10
  16143.     CALL VWRT('# rows to move down on col overflow:',34)
  16144.     if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)IRREF
  16145.     if(ill.eq.11)call vgeti(irref)
  16146.     IF(IRREF.GT.(MRows-1))IRREF=50
  16147.     IF(IRREF.LT.0)IRREF=50
  16148. C FORCE THE RESULTS TO MAKE SENSE. 0 TO 60 ON COLS, 0-300 ON ROWS.
  16149. C IF USER BOTHERS TO READ MANUALS THIS WILL BE EXPLAINED.
  16150. 3502    CONTINUE
  16151.     CALL VWRT('Reset Display to Upper Left of Sheet Y/N:',40)
  16152.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16153.     if(ill.eq.11)call vget(form,4)
  16154.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')KMAP=0
  16155. 3006    FORMAT(80A1,50A1)
  16156. 3000    CONTINUE
  16157.     RETURN
  16158. 5600    CONTINUE
  16159.     IOLVL=11
  16160.     CLOSE(3)
  16161. c    Rewind 11
  16162. c    CLOSE(11)
  16163. c    OPEN(11,FILE='CON:0/0/100/100/Analy Command',
  16164. c     1  STATUS='OLD',FORM='FORMATTED')
  16165.     RETURN
  16166.     END
  16167. c -h- acini3.for    Fri Aug 22 12:55:39 1986    
  16168. C PORTACALC MAIN PROGRAM
  16169. C SPREAD SHEET DRIVER PROGRAM
  16170. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  16171. C ALL RIGHTS RESERVED
  16172. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  16173. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  16174. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  16175. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  16176. C FROM THE DISK BASED FILE HERE.
  16177.     SUBROUTINE INITB(KMAP,KWID,ICODE)
  16178. C
  16179.     Include AParms.inc
  16180.     InTeGer*4 PRL(6)
  16181.         CHARACTER*1 NOWRAP ( 2 )
  16182.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  16183.     INTEGER*4 VNLT
  16184.     INTEGER IFCW
  16185. C    EXTERNAL LCWRQQ
  16186.     DIMENSION FORM(128),FVLD(1,1)
  16187. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  16188. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  16189. C SO INITIALLY IGNORE.
  16190. C
  16191. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  16192. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  16193. C ***<<<< RDD COMMON START >>>***
  16194.     InTeGer*4 RRWACT,RCLACT
  16195. C    COMMON/RCLACT/RRWACT,RCLACT
  16196.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  16197.      1  IDOL7,IDOL8
  16198. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  16199. C     1  IDOL7,IDOL8
  16200.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  16201. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16202.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16203. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16204. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  16205. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  16206.     InTeGer*4 KLVL
  16207. C    COMMON/KLVL/KLVL
  16208.     InTeGer*4 IOLVL,IGOLD
  16209. C    COMMON/IOLVL/IOLVL
  16210. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16211. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16212.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  16213.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  16214.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  16215.      3  k3dfg,kcdelt,krdelt,kpag
  16216. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  16217. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  16218. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  16219. C ***<<< RDD COMMON END >>>***
  16220. CCC    InTeGer*4 RRWACT,RCLACT
  16221. CCC    COMMON/RCLACT/RRWACT,RCLACT
  16222. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  16223. CCC     1  IDOL7,IDOL8
  16224. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  16225. CCC     1  IDOL7,IDOL8
  16226. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16227. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16228.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  16229.     COMMON/D2R/NRDSP,NCDSP
  16230. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16231. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16232. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  16233. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  16234.     CHARACTER*1 FORM2(4)
  16235. C ***<<< XVXTCD COMMON START >>>***
  16236.     CHARACTER*1 OARRY(100)
  16237.     InTeGer*4 OSWIT,OCNTR
  16238. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  16239. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16240.     InTeGer*4 IPS1,IPS2,MODFLG
  16241. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16242.        InTeGer*4 XTCFG,IPSET,XTNCNT
  16243.        CHARACTER*1 XTNCMD(80)
  16244. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16245. C VARY FLAG ITERATION COUNT
  16246.     INTEGER KALKIT
  16247. C    COMMON/VARYIT/KALKIT
  16248.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  16249.     InTeGer*4 RCMODE,IRCE1,IRCE2
  16250. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16251. C     1  IRCE2
  16252. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16253. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  16254. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  16255. C RCFGX ON.
  16256. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  16257. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  16258. C  AND VM INHIBITS. (SETS TO 1).
  16259.     INTEGER*4 FH
  16260. C FILE HANDLE FOR CONSOLE I/O (RAW)
  16261. C    COMMON/CONSFH/FH
  16262.     CHARACTER*1 ARGSTR(52,4)
  16263. C    COMMON/ARGSTR/ARGSTR
  16264.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  16265.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  16266.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16267.      3  IRCE2,FH,ARGSTR
  16268. C ***<<< XVXTCD COMMON END >>>***
  16269. CCC    InTeGer*4 OSWIT,OCNTR
  16270.  
  16271. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  16272. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16273.     InTeGer*4 TYPE(1,1),VLEN(9)
  16274. CCC    InTeGer*4 KLVL
  16275. CCC    COMMON/KLVL/KLVL
  16276. CCC    InTeGer*4 IOLVL
  16277. CCC    COMMON/IOLVL/IOLVL
  16278. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16279. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16280.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  16281.     REAL*8 XXV(1,1)
  16282.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  16283.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  16284. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  16285.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  16286.     CHARACTER*12 CDVFMT
  16287.     EQUIVALENCE(DEFFMT(1),DVFMT(2))
  16288.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  16289.     COMMON/DEFVBX/DVFMT
  16290.     CHARACTER*1 NMSH(80)
  16291.     CHARACTER*80 NMSH80
  16292.     EQUIVALENCE(NMSH80(1:1),FORM(1))
  16293.     COMMON/NMSH/NMSH
  16294. CCC    InTeGer*4 IPS1,IPS2,MODFLG
  16295. CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16296. CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
  16297. CCC       CHARACTER*1 XTNCMD(80)
  16298. CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16299. C VARY FLAG ITERATION COUNT
  16300. CCC    INTEGER KALKIT
  16301. CCC    COMMON/VARYIT/KALKIT
  16302. CCC    InTeGer*4 FORMFG,RCFGX,PZAP
  16303. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP
  16304. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16305. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  16306. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  16307. C RCFGX ON.
  16308. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  16309. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  16310. C  AND VM INHIBITS. (SETS TO 1).
  16311. C
  16312. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  16313. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  16314. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  16315. C DISPLAY ACTUALLY USED FOR SCREEN.
  16316.     InTeGer*4 CWIDS(20)
  16317. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  16318. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  16319. C AS 20 NOT 75.
  16320.     INTEGER*4 I4TMP
  16321.     REAL*8 DVS(20,75)
  16322.     COMMON /FVLDC/FVLD
  16323. C FOLLOWING SUPPORT VVARY OVERLAY:
  16324.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  16325.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  16326.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  16327. C BITMAP
  16328. C    CHARACTER*1 IBITMP
  16329. C    DIMENSION IBITMP(2258)
  16330. C    COMMON/INITD/IBITMP
  16331. C    CHARACTER*1 DFMTS(10,20,75)
  16332. C 10 CHARACTERS PER ENTRY.
  16333.     COMMON/DSPCMN/DVS,CWIDS
  16334.     character*35 fwt
  16335. C    DATA NOWRAP / "24,0 /
  16336. C
  16337.     idol5=20000
  16338.     idol6=20000
  16339. C INITIALLY SET JRCL TO 301 = NO. OF ROWS TO BE IN WORK FILE
  16340.     JRCL=MRows
  16341.     PZAP=0
  16342.     XTCFG=0
  16343.     IPSET=0
  16344. C ZERO BITMAP
  16345. C    DO 36 N1=1,2258
  16346. C36    IBITMP(N1)=0
  16347. c    LINIZZ=0
  16348.     CALL UVT100(1,14,1)
  16349.     CALL VWRT('Enter NEW floating format default Y/N:',38)
  16350.     ILL=IOLVL
  16351. C    IF(ILL.EQ.5)ILL=0
  16352.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16353.     if(ill.eq.11)call vget(form,4)
  16354.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3589
  16355. C ENTER NEW DEFAULT.
  16356. 6888    CALL UVT100(1,14,1)
  16357.     CALL UVT100(12,2,0)
  16358. C LINE NOW ERASED... GET NEW FORMAT
  16359.     CALL VWRT('Enter new format. Suggest F10.2>',32)
  16360.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16361.     if(ill.eq.11)call vget(form,16)
  16362. C NOW HAVE HIS DESIRED FORMAT. COPY INTO THE DEFAULT ARRAY.
  16363. C DEFFMT IS THAT.
  16364.     DO 3591 N1=1,10
  16365.     KKK=ICHAR(FORM(N1))
  16366.     KKK=MAX0(32,KKK)
  16367. C ASSUME NMSH COMPLETELY INIT'D
  16368. 3591    DEFFMT(N1)=Char(KKK)
  16369. c    dvfmt(1)='('
  16370. c    dvfmt(12)=')'
  16371. C CHECK ITS LEGALITY BY TRYING TO USE IT ONCE.
  16372.     XX=3.14159
  16373.     WRITE(NMSH80(1:80),DVFMT,ERR=6888)XX
  16374. C    ENCODE(78,DVFMT,NMSH,ERR=6888)XX
  16375. C IF IT FAILS, PROGRAM WILL CRASH AND FILE WON'T GET CLOBBERED.
  16376. 3589    CONTINUE
  16377.     CALL UVT100(1,15,1)
  16378.     CALL VWRT('Title for Spreadsheet:',22)
  16379.     ILL=IOLVL
  16380. C    IF(ILL.EQ.5)ILL=0
  16381.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16382.     if(ill.eq.11)call vget(form,120)
  16383. 3006    FORMAT(80A1,50A1)
  16384.     IF(ICHAR(FORM(1)).LE.32.AND.ICHAR(FORM(2)).LE.32) GOTO 3008
  16385. C COPY TITLE UNLESS IT'S OLD
  16386.     DO 3007 KKK=1,80
  16387. 3007    NMSH(KKK)=FORM(KKK)
  16388. C THAT WAY JUST C.R. LEAVES IN OLD TITLE.
  16389. 3008    CONTINUE
  16390. C ****** IF S OPTION GIVEN THEN ICODE=-2
  16391. C THEREFORE, DON'T ASK DISK SIZE ETC, BUT ALLOW RESET OF TITLE
  16392. C AND DEFAULT FORMATS.
  16393.     IF(ICODE.EQ.-2) GOTO 7831
  16394. C ******
  16395.     CALL UVT100(1,16,1)
  16396.     CALL VWRT('Give Max Rows to be used:',25)
  16397.     if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)KR
  16398.     if(ill.eq.11)call vgeti(kr)
  16399.     IF(KR.LE.0)KR=MRows
  16400.     CALL UVT100(1,17,1)
  16401.     CALL VWRT('Give Max Cols to be used:',25)
  16402.     if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)KC
  16403.     if(ill.eq.11)call vgeti(kc)
  16404.     IF(KC.LE.0)KC=MCols
  16405. C    KKK=(KR-1)*60+KC
  16406. C ALLOW REPLIES IN ANY RANGE AND REFLECT BACK TO PRIME RANGE
  16407. C NOTE WE WANT A CELL ADDRESS HERE FOR THE END CELL...
  16408.     CALL REFLEC(KR,KC,KKK)
  16409.     XKKKK=KR*KC
  16410.     XKDF=XKKKK/64.
  16411.     XKDN=XKKKK/100.
  16412. C COMPUTED ABOVE THE MIN # OF K FOR DISK FILES
  16413.     CALL UVT100(1,18,1)
  16414.     write(fwt(1:12),2058)xkdn
  16415. 2058    format(F9.0)
  16416.     CALL SWRT('Min=',4)
  16417.     call swrt(fwt(1:12),9)
  16418.     write(fwt,2058)xkdf
  16419.     call swrt(' K Value file ',14)
  16420.     CALL SWRT(fwt(1:12),9)
  16421.     CALL SWRT(' K Formula file',15)
  16422. c    WRITE(0,2058)XKDN,XKDF
  16423. c2058    FORMAT(' Mins=',F9.0' K Value file, ',F9.0,' K Formula file',\)
  16424. C KKK IS MAX INDEX TO BE USED HERE.
  16425.     CALL UVT100(1,21,1)
  16426.     CALL VWRT('Give Value File size, K:',24)
  16427.     if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)IPGMAX
  16428.     if(ill.eq.11)call vgeti(ipgmax)
  16429. 7202    FORMAT(I6)
  16430.     IPGMOD=KKK
  16431.     IF(IPGMAX.LT.0)IPGMOD=0
  16432.     IPGMAX=IABS(IPGMAX)
  16433.     IF(IPGMAX.GT.2512)IPGMAX=1
  16434.     CALL UVT100(1,22,1)
  16435.     CALL VWRT('Give Formula File size, K:',26)
  16436.     if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)LPGMXF
  16437.     if(ill.eq.11)call vgeti(lpgmxf)
  16438.     LPGMOD=KKK
  16439.     IF(LPGMXF.LT.0)LPGMOD=0
  16440.     LPGMXF=IABS(LPGMXF)
  16441. C IF NUMBERS ARE ENTERED NEGATIVE, SET MODE TO "SLOW, FILE-SPACE
  16442. C CONSERVING" PACKING, SCATTERING PAGES ACROSS FILE.
  16443.     IF(LPGMXF.GT.4096)LPGMXF=(IPGMAX*3)/2
  16444. C NULL TERMINATE ALL FORMAT STRINGS.
  16445. C SET MAX WIDTH FOR PRINT TO DIMENSION OF THE BUFFER. NOTE THIS IS THE
  16446. C USUAL HARDWARE MAXIMUM SO WE DON'T WORRY TOO MUCH ABOUT IT. NOTE
  16447. C BILL TABOR'S PROGRAM TO PRINT PASTE-ABLE VERSIONS OF THE SHEET FROM
  16448. C SAVE FILES EXISTS, SO WE NEEDN'T WORRY TOO MUCH EITHER ABOUT USING
  16449. C DISPLAY FOR DOUBLE DUTY.
  16450.     MXL=132
  16451. C INITIALIZE WORK STORAGE FOR FORMULAS AND VARIABLES
  16452.     CALL WSSET
  16453. 7831    CONTINUE
  16454. C SET DEFAULT WIDTHS OF COLUMNS TO 10. MAY BE ALTERED BELOW FOR DIFFERENT
  16455. C DEFAULT IF DESIRED.
  16456.     DO 16 N1=1,20
  16457.     CWIDS(N1)=KWID
  16458. 16    CONTINUE
  16459. C
  16460. C NOW SET UP NRDSP, NCDSP
  16461.     IF(KMAP.EQ.0)GOTO 3009
  16462. C SET UP MAPPING NOW FOR INITIALLY UPPER LEFT CORNER OF PHYS SHEET IN DISPLAY SHT.
  16463.     DO 5 N1=1,20
  16464.     DO 5 N2=1,75
  16465. C INITIALLY WE DISPLAY THE UPPER LEFT PART OF THE SYSTEM.
  16466. C ESTABLISH ASSOCIATION INITIALLY THEREFORE OF DISPLAY TO UPPER
  16467. C LEFT OF PHYSICAL SHEET.
  16468.     NRDSP(N1,N2)=N1
  16469.     NCDSP(N1,N2)=N2+1
  16470.     DVS(N1,N2)=.00000031
  16471. 5    CONTINUE
  16472. C FOR S OPTION USE SECRET -4 CODE TO RESET SHEET. STILL NEEDS WORK
  16473. C IN PORTACALC PC.
  16474.     IF(ICODE.EQ.-4)CALL WRKFIL(1,FORM,2)
  16475. 3009    IF(ICODE.EQ.-4)GOTO 1
  16476. C43    CALL UVT100(1,21,1)
  16477.     KZPPD=0
  16478.     CMDLIN(1)=Char(0)
  16479.     IOLDFL=0
  16480. C3017    FORMAT(Q,80A1,80A1)
  16481.     MXL=1
  16482.     CMDLIN(MXL+1)=Char(0)
  16483. 3572    FORMAT(I6)
  16484.     CALL UVT100(13,0,0)
  16485. C  SET UP RANDOM FILE AS NEEDED FOR SHEET
  16486. C EACH RECORD HAS:
  16487. C CHARS 1-110    FORMULAS
  16488. C CHARS 120-128    DISPLAY FORMAT (INITIALLY F9.2)
  16489. C CHAR 119    VALID FLAG (ALLOWS HANDLING READS.)
  16490. C    values: -3, -2: Numeric-only text (or special chars)
  16491. C         -1    : Alphanumeric text
  16492. C          0    : Uninitialized
  16493. C          1    : Alphanumeric formula
  16494. C         +2    : Number or pure numeric formula with value calculated
  16495. C         +3    : Number or pure numeric formula, value not yet computed
  16496. C CHAR 118    MAGIC NUMBER 15 (CHECKS ALL WELL)
  16497. C READ A RECORD, IF ERROR, CREATE EMPTY FILE.
  16498. C    IF(IOLDFL.EQ.0)GOTO 1
  16499. CC IF IOLDFL NONZERO IT MEANS USER CLAIMS THERE EXISTS A FILE. IF 0 IT'S NEW.
  16500. CC HERE IT'S OLD SO LET'S BE SURE IT REALLY IS OK.
  16501. 1    CONTINUE
  16502. C HIT EOF OR ERROR. MUST BE A NEW FILE. THEREFORE ZERO IT TO OUR NEEDS.
  16503. C AT THIS POINT WE ARE CREATING A NEW FILE AND NEED TO ZERO IT.
  16504. C
  16505.     DO 3 N=1,128
  16506.     FORM(N)=Char(0)
  16507. 3    CONTINUE
  16508.     DO 3592 N=1,9
  16509. C SET UP DEFAULT FORMAT
  16510. 3592    FORM(119+N)=DEFFMT(N)
  16511.     FORM(118)=CHAR(15)
  16512.     FORM(1)='0'
  16513.     FORM(2)='.'
  16514. C CREATE NULL FILE INITIALLY BY RESETTING ALL.
  16515.     JRRCL=MCols*JRCL
  16516.     KZPPD=1
  16517. C
  16518. 2    CONTINUE
  16519. C COMMON POINT WITH FILE PREPARED.
  16520.     PCOL=2
  16521.     PROW=1
  16522.     DCOL=1
  16523.     DROW=1
  16524.     RETURN
  16525. 5600    CONTINUE
  16526. C ERROR ON READ FROM IOLVL HANDLED HERE.
  16527. C    REWIND 5
  16528.     Rewind 11
  16529. c    CLOSE(11)
  16530. c    OPEN(11,FILE='CON:0/150/500/49/Analy Command',
  16531. c     1  STATUS='OLD',FORM='FORMATTED')
  16532.     CLOSE(3)
  16533.     IOLVL=11
  16534.     RETURN
  16535.     END
  16536. c -h- block.for    Fri Aug 22 12:58:14 1986    
  16537.     SUBROUTINE BLOCK
  16538. C    BLOCK DATA
  16539. C COPYRIGHT (C) 1983 GLENN EVERHART
  16540. C ALL RIGHTS RESERVED
  16541. C 18060 = 60*301
  16542. C 18033=18060-27
  16543. C 60=MAX REAL ROWS
  16544. C 301=MAX REAL COLS
  16545. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  16546. C VBLS AND TYPE DIMENSIONED 60,301
  16547.     Include AParms.Inc
  16548. C   ++++++++++++++++++++++++++++++++++++++++++++++++++
  16549. C   +                                                +
  16550. C   +            CALC    VERSION  X01-06             +
  16551. C   +                                                +
  16552. C   ++++++++++++++++++++++++++++++++++++++++++++++++++
  16553. C
  16554. C
  16555. C *******************************************************
  16556. C *                                                     *
  16557. C *            BLOCK  DATA  MODULE                      *
  16558. C *                                                     *
  16559. C *******************************************************
  16560. C
  16561. C
  16562. C COMMON AREAS ARE INITIALIZED BY THIS MODULE.
  16563. C FAKEUP FOR MICROSOFT WHICH HAS NO BLOCK DATA.
  16564. C DO IT ALL VIA LOOPS...
  16565. C
  16566. C
  16567. C MODIFIED 18-MAY-1981 P.B. SET % TO VERSION 6
  16568. C
  16569. C
  16570. C
  16571. C   VARIABLE      USE
  16572. C
  16573. C  ALPHA(27)    HOLDS LEGAL VARIABLE NAMES: ALPHABETIC CHARACTERS
  16574. C               OR THE CHARACTER %.
  16575. C  BASED     HOLDS DEFAULT BASE.
  16576. C  BLANK        ' '
  16577. C  COMMA        ','
  16578. C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
  16579. C               SECOND SUBSCRIPT IS
  16580. C                     1 FOR DECIMAL
  16581. C                     2 FOR OCTAL
  16582. C                     3 FOR HEXADECIMAL
  16583. C  DTBL1(9,9,8) CONTROLS THE DECISION PROCESS WHEN EVALUATING A
  16584. C               BINARY OPERATION. SEE BELOW FOR DETAILS.
  16585. C  EQ           '='
  16586. C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
  16587. C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
  16588. C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
  16589. C               USED TO CONTROL ITERATION.
  16590. C  LINE(80)     COMMAND INPUT LINE
  16591. C  LPAR         '('
  16592. C  RPAR         ')'
  16593. C  ST1LIM       HOLDS THE SIZE OF STACK 1 (ALWAYS CONSTANT)
  16594. C  ST2LIM       HOLDS THE SIZE OF STACK 2 (ALWAYS CONSTANT)
  16595. C  ST1PT        POINTS TO THE TOP OF STACK 1 (CHANGES AS STACK IS USED)
  16596. C  ST2PT        POINTS TO THE TOP OF STACK 2 (CHANGES AS STACK IS USED)
  16597. C  ST1TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 1
  16598. C  ST2TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 2
  16599. C  STACK1(20,40)   UTILITY STACKS USED WHEN EVALUATING EXPRESSIONS. THE FIRST
  16600. C  STACK2(20,40)   SUBSCRIPT CONTROLS INDEXING ACROSS THE BYTES OF A SINGLE
  16601. C                   VARIABLE. THE SECOND SUBSCRIPT CONTROLS STACK ELEMENTS.
  16602. C  TYPE(27)         HOLDS THE DATA TYPES FOR EACH OF THE 27 VARIABLES. SEE
  16603. C                   CODES.FTN FOR THE POSSIBLE VALUES.
  16604. C  VIEWSW           VIEW SWITCH
  16605. C                    0 = OUTPUT ERROR MESSAGES
  16606. C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
  16607. C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
  16608. C                        EVALUATED.
  16609. C                    3 = OUTPUT EVERYTHING
  16610. C  VLEN(9)      INDEXED BY DATA TYPE. GIVES THE NUMBER OF BYTES USED
  16611. C               BY THAT DATA TYPE.
  16612. C  AVBLS(20,27)      HOLDS THE VALUES OF THE 27 LEGAL VARIABLES.(ACCUMULATORS)
  16613. C  VBLS(8,60,301)    HOLDS VALUES OF ALL VARIABLES
  16614. C
  16615. C
  16616. C
  16617. C    CONSTANTS ARE STORED IN VBLS ACCORDING TO THEIR TYPE:
  16618. C
  16619. C
  16620. C
  16621. C <----------- MULTIPLE PRECISION (M10, M8, M16) ------------------------->
  16622. C !                        <------------- DECIMAL AND REAL --------------->
  16623. C !                        !                      <-- INTEGER HEX OCTAL -->
  16624. C !                                               !             ---> ASCII <---
  16625. C !                        !                      !                        !
  16626. C
  16627. C -------------     -------------------------------------------------------
  16628. C !     !     !     !     !     !     !     !     !     !     !     !     !
  16629. C ! 20  !  19 ! ... !  9  !  8  !  7  !  6  !  5  !  4  !  3  !  2  !  1  !
  16630. C !     !     !     !     !     !     !     !     !     !     !     !     !
  16631. C -------------     -------------------------------------------------------
  16632. C
  16633. C
  16634. C NOTE: BYTE 20 HOLDS THE SIGN FOR MULTIPLE PRECISION NUMBERS.
  16635. C       0 = POSITIVE, 1 = NEGATIVE
  16636. C
  16637. C
  16638. C
  16639. C
  16640. C
  16641. C    BLOCK DATA
  16642.     InTeGer*4 LEVEL,NONBLK,LEND
  16643.     InTeGer*4 LASTOP
  16644.     InTeGer*4 ST1TYP(40),ST2TYP(40)
  16645.     InTeGer*4 TYPE(1,1)
  16646.     InTeGer*4 VIEWSW,BASED,VLEN(9),BVLEN(9)
  16647.     InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
  16648.     InTeGer*4 ITCNTV(6)
  16649. C
  16650.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ,LINE(80)
  16651.     CHARACTER*1 BOMMA,BBLANK,BRPAR,BLPAR,BEQ
  16652.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  16653.     CHARACTER*1 AVBLS(20,27),BLPHA(27)
  16654.     CHARACTER*1 VBLS(8,1,1)
  16655. C ***<<< XVXTCD COMMON START >>>***
  16656.     CHARACTER*1 OARRY(100)
  16657.     InTeGer*4 OSWIT,OCNTR
  16658. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  16659. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16660.     InTeGer*4 IC1POS,IC2POS,MODFLG
  16661. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16662.        InTeGer*4 XTCFG,IPSET,XTNCNT
  16663.        CHARACTER*1 XTNCMD(80)
  16664. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16665. C VARY FLAG ITERATION COUNT
  16666.     INTEGER KALKIT
  16667. C    COMMON/VARYIT/KALKIT
  16668.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  16669.     InTeGer*4 RCMODE,IRCE1,IRCE2
  16670. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16671. C     1  IRCE2
  16672. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16673. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  16674. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  16675. C RCFGX ON.
  16676. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  16677. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  16678. C  AND VM INHIBITS. (SETS TO 1).
  16679.     INTEGER*4 FH
  16680. C FILE HANDLE FOR CONSOLE I/O (RAW)
  16681. C    COMMON/CONSFH/FH
  16682.     CHARACTER*1 ARGSTR(52,4)
  16683. C    COMMON/ARGSTR/ARGSTR
  16684.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  16685.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  16686.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16687.      3  IRCE2,FH,ARGSTR
  16688. C ***<<< XVXTCD COMMON END >>>***
  16689. CCC    InTeGer*4 IC1POS,IC2POS
  16690. CCC    COMMON/ICPOS/IC1POS,IC2POS
  16691.     CHARACTER*1 DTBL1(9,9,8)
  16692. CC BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  16693. C MOVED TABLE TO WRKFIL WHERE IT IS OVERLAIN BY A BUFFER DURING OPERATION
  16694. C AND JUST INITIALIZES DTBL1 AT STARTUP. THIS SHOULD ESSENTIALLY REMOVE DATA
  16695. C SPACE PENALTY FOR THIS HUGE ARRAY. NOTE IT'D BE SMALLER IF THERE WEREN'T
  16696. C SO MANY SUPPORTED DATA TYPES IN CALC.
  16697. C    InTeGer*4 BTBL(9,9,8)
  16698. C    InTeGer*4 BTBL1(9,9)
  16699. C    InTeGer*4 BTBL2(9,9),BTBL3(9,9),BTBL4(9,9),BTBL5(9,9)
  16700. C    InTeGer*4 BTBL6(9,9),BTBL7(9,9),BTBL8(9,9)
  16701. C    EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  16702. C    EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  16703. C    EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  16704. C    EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  16705.     CHARACTER*1 DIGITS(16,3),BIGITS(16,3)
  16706. C
  16707. C OARRY WILL BE USED TO HOLD OUTPUT VARIABLE IF OSWIT IS NONZERO
  16708. CCC    InTeGer*4 OSWIT
  16709. C OCNTR MAY HOLD BYTES VALID IN OARRY (UP TO 100, NO MORE...)
  16710. CCC    InTeGer*4 OCNTR
  16711. CCC    CHARACTER*1 OARRY(100)
  16712. C
  16713. C ILINE IS PROGRAMMABLE LINE INPUT (I.E., NOT FROM CONSOLE)
  16714.     CHARACTER*1 ILINE(106)
  16715.     InTeGer*4 ILNFG
  16716.     InTeGer*4 ILNCT
  16717.     COMMON /ILN/ILNFG,ILNCT,ILINE
  16718. C ILINE IS PRESENT IF ILNFG <> 0 AND ILNCT HAS # BYTES IN IT.
  16719. CCC    COMMON /OAR/OSWIT,OCNTR,OARRY
  16720.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  16721.     COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  16722.     COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  16723.      ;         ST1LIM,ST2LIM
  16724.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  16725.     COMMON /DECIDE/ DTBL1
  16726.     COMMON /DIGV/ DIGITS
  16727. C ***<<< KLSTO COMMON START >>>***
  16728.     InTeGer*4 DLFG
  16729. C    COMMON/DLFG/DLFG
  16730.     InTeGer*4 KDRW,KDCL
  16731. C    COMMON/DOT/KDRW,KDCL
  16732.     InTeGer*4 DTRENA
  16733. C    COMMON/DTRCMN/DTRENA
  16734.     REAL*8 EP,PV,FV
  16735.     DIMENSION EP(20)
  16736.     INTEGER*4 KIRR
  16737. C    COMMON/ERNPER/EP,PV,FV,KIRR
  16738. c    InTeGer*4 LASTOP
  16739. C    COMMON/ERROR/LASTOP
  16740.     CHARACTER*1 FMTDAT(9,76)
  16741. C    COMMON/FMTBFR/FMTDAT
  16742.     CHARACTER*1 EDNAM(16)
  16743. C    COMMON/EDNAM/EDNAM
  16744.     InTeGer*4 MFID(2),MFMOD(2)
  16745. C    COMMON/FRM/MFID,MFMOD
  16746.     InTeGer*4 JMVFG,JMVOLD
  16747. C    COMMON/FUBAR/JMVFG,JMVOLD
  16748.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  16749.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  16750. C ***<<< KLSTO COMMON END >>>***
  16751. CCC    COMMON /ERROR/ LASTOP
  16752.     COMMON/ITERA/ ITCNTV
  16753.     CHARACTER*1 DVFMT(12),BVFMT(12)
  16754.     COMMON/DEFVBX/DVFMT
  16755. C SUPPORT VVARY OVERLAY WITH INITIAL VARY DATA:
  16756.     REAL*8 QAC(26),QDERIV(8),QDEL(8),QOLDVV
  16757.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  16758.     COMMON/VRYDAT/QAC,QDERIV,QDEL,QCAC,QCENT,QOLDVV,ACV
  16759. C INITIAL DEFAULT FORMAT FOR NUMERICS
  16760.     DATA BVFMT/'(','F','9','.','2',' ',
  16761.      1  ' ',' ',' ',' ',' ',')'/
  16762. C
  16763. C    DATA BIEWSW/2/
  16764. C    DATA ITCNTV/6*0/
  16765.     DATA BLPHA/'A','B','C','D','E','F','G','H','I','J','K','L','M',
  16766.      ;       'N','O','P','Q','R','S','T','U','V','W','X','Y','Z','%'/
  16767.     DATA BIGITS/'1','2','3','4','5','6','7','8','9',
  16768.      1  '0','0','0','0','0','0','0',
  16769.      ;       '1','2','3','4','5','6','7',
  16770.      1  '0','0','0','0','0','0','0','0','0',
  16771.      ;  '1','2','3','4','5','6','7','8','9','A','B','C','D','E','F','0'/
  16772.     DATA BOMMA/','/,BBLANK/' '/,BRPAR/')'/,BLPAR/'('/,BEQ/'='/
  16773. C
  16774. C
  16775. C DEFAULT BASE IS 10
  16776. C    DATA BASED/10/
  16777. C
  16778. C
  16779. C STACKS ARE CURRENTLY SET AT 40 ELEMENTS DEEP
  16780. C    DATA ST1LIM/40/, ST2LIM/40/
  16781. C
  16782. C
  16783. C
  16784. C    DEFAULT TYPES
  16785. C    A,B,C,D,E,F,G,H  =  DECIMAL
  16786. C    I,J,K,L,M,N      =  INTEGER (BASE10)
  16787. C    O,P,Q,R,S,T,U,V,W,X,Y,Z  =  DECIMAL
  16788. C
  16789. C  % AS INTEGER TO HOLD CALC VERSION NUMBER
  16790. C
  16791. C    DATA TYPE/8*2,6*4,12*2,4,1*2/
  16792. c modify type array so ac's i-n are reals
  16793. C    DATA TYPE/8*2,6*2,12*2,2,1*2/
  16794. C
  16795. C
  16796. C GIVE VERSION # BY VALUE IN %
  16797. C
  16798. c don't bother with this; by the time user gets into calc,
  16799. c % already is clobbered most times, so no need for it.
  16800. c    DATA AVBLS(1,27)/6/
  16801. c    DATA AVBLS(2,27)/0/,AVBLS(3,27)/0/,AVBLS(4,27)/0/
  16802. C
  16803. C
  16804. C
  16805. C
  16806. C SPECIFY THE LENGTH USED BY EACH DATA TYPE
  16807.     DATA BVLEN/1,8,4,4,8,8,8,4,8/
  16808. C
  16809. C NOTE ALL LENGTHS 8 OR LESS SINCE MULTIPLE PRECISION THINGS SNIPPED OUT
  16810. C
  16811. C  DECISION TABLE FOR PERFORMING BINARY OPERATIONS
  16812. C
  16813. C  DTBL1(OPERAND2,OPERAND1,INDEX)
  16814. C
  16815. C  WHERE:                    OPERATOR:
  16816. C  INDEX=1    MODIFY CODE FOR OPERAND 1    */+-
  16817. C     2    MODIFY CODE FOR OPERAND 2    */+-
  16818. C     3    FUNCTION VALUE TYPE        */+-
  16819. C     4    OPERATOR CLASS            */+-
  16820. C
  16821. C     5    MODIFY CODE FOR OPERAND 1    **
  16822. C     6    MODIFY CODE FOR OPERAND 2    **
  16823. C     7    FUNCTION VALUE TYPE        **
  16824. C     8    OPERATOR CLASS            **
  16825. C
  16826. C
  16827. C  WHERE TYPE CODES (MODIFY CODES) ARE:
  16828. C    0    NO CHANGE
  16829. C    1    CONVERT TO ASCII
  16830. C    2    CONVERT TO DECIMAL
  16831. C    3    CONVERT TO HEXADECIMAL
  16832. C    4    CONVERT TO INTEGER
  16833. C    5    CONVERT TO M10
  16834. C    6    CONVERT TO M8
  16835. C    7    CONVERT TO M16
  16836. C    8    CONVERT TO OCTAL
  16837. C    9    CONVERT TO REAL
  16838. C
  16839. C  FOR */+- FUNCTION VALUE TYPES AND OPERATOR CLASS ARE PRESENTLY
  16840. C  IDENTICAL
  16841. C
  16842. C  FOR **  OPERATOR CLASSES FOLLOW:
  16843. C
  16844. C     CODE    OPERATOR CLASS
  16845. C    1    REAL**REAL
  16846. C    2    REAL**INTEGER
  16847. C    3    INTEGER**REAL
  16848. C    4    INTEGER**REAL
  16849. C    5    M8**INTEGER
  16850. C    6    M10**INTEGER
  16851. C    7    M16**INTEGER
  16852. C
  16853. C
  16854. C
  16855. C    DATA BTBL1 /4,2,3,4,5,6,7,8,9,
  16856. C     1  9*0,0,2,0,0,3*7,0,9,0,2,0,0,5,5,7,0,9,0,2,7,0,0,0,7,0,9,
  16857. C     2  0,2,7,5,5,0,7,0,9,0,2,6*0,9,0,2,3,0,5,6,7,0,9,0,2,7*0/
  16858. C    DATA BTBL2/
  16859. C     3  4,8*0,2,0,6*2,0,3,3*0,7,7,3*0,4,4*0,5,3*0,5,0,7,5,0,5,0,5,0,
  16860. C     4  6,0,7,5,3*0,6,0,7,2,4*7,0,7,0,8,8*0,9,0,6*9,0/
  16861. C    DATA BTBL3/4,2,3,4,5,6,7,8,9,
  16862. C     5  9*2,3,2,3,3,3*7,3,9,4,2,3,4,5,5,7,4,9,5,2,7,3*5,7,5,9,
  16863. C     6  6,2,7,5,5,6,7,6,9,7,2,6*7,9,8,2,3,4,5,6,7,8,9,9,2,7*9/
  16864. C    DATA BTBL4/
  16865. C     7  4,2,3,4,5,6,7,8,9,9*2,3,2,3,3,3*7,3,9,4,2,3,4,5,5,7,4,9,
  16866. C     8  5,2,7,5,5,5,7,5,9,6,2,7,5,5,6,7,6,9,7,2,6*7,9,8,2,3,4,5,6,7,8,9,
  16867. C     9  9,2,7*9/
  16868. C    DATA BTBL5/4,2,3,6*4,9*0,9*0,9*0,0,9,6*0,9,0,9,6*0,9,0,9,6*0,9,
  16869. C     1  9*0,9*0/
  16870. C    DATA BTBL6/4,3*0,3*9,4,0,4,3*0,3*9,0,0,4,3*0,3*9,2*0,4,3*0,3*9,
  16871. C     2  2*0,4,3*0,3*4,2*0,4,3*0,3*4,2*0,4,3*0,3*4,2*0,4,3*0,3*9,2*0,
  16872. C     3  4,3*0,3*9,2*0/
  16873. C        DATA BTBL7/4,2,3,6*4,9*2,9*3,9*4,5,9,6*5,9,6,9,6,6,5,6,7,6,9,
  16874. C     4  7,9,6*7,9,9*8,9*9/
  16875. C    DATA BTBL8/4,1,4,4,3,3,3,4,3,2,1,2,2,3*1,2,1,4,3,4,4,3*3,
  16876. C     5  4,3,4,3,4,4,3*3,4,3,6,1,6*6,1,5,1,6*5,1,7,1,6*7,1,4,3,4,4,3*3,
  16877. C     6  4,3,2,1,2,2,3*1,2,1/
  16878. C
  16879. C HERE COPY LOCAL DATA INTO THE COMMONS.
  16880. C SINCE MOST ARRAYS AND THINGS ARE SMALL, WE JUST DO IT WITH REGULAR FORTRAN.
  16881. C THE BTBL ARRAY IS HANDLED IN WRKFIL WHERE THERE'S A BIG ENOUGH ARRAY FOR
  16882. C SCRATCH SPACE TO HOLD THE INITIAL DATA; WRKFIL IS CALLED BY WSSET WITH
  16883. C "SECRET CODE" TO INIT DTBL1 FROM THE ARRAY AND DOES SO ONCE ONLY.
  16884.     VIEWSW=0
  16885.     LEVEL=1
  16886.     LASTOP=0
  16887.     BASED=10
  16888.     COMMA=BOMMA
  16889.     BLANK=BBLANK
  16890.     RPAR=BRPAR
  16891.     LPAR=BLPAR
  16892.     EQ=BEQ
  16893.     DO 1 N=1,6
  16894.     ITCNTV(N)=0
  16895. 1    CONTINUE
  16896.     DO 2 N=1,27
  16897.     DO 12 NN=1,20
  16898. 12    AVBLS(NN,N)=Char(0)
  16899. 2    ALPHA(N)=BLPHA(N)
  16900.     ST1LIM=40
  16901.     ST2LIM=40
  16902. C THIS IS DONE IN WRKFIL SINCE THERE'S A BIG LOCAL ARRAY THERE
  16903. C WE CAN KEEP EQUIVALENCED TO THIS ONE...
  16904. C    DO 3 N2=1,9
  16905. C    DO 3 N1=1,9
  16906. C    DTBL1(N1,N2,2)=BTBL2(N1,N2)
  16907. C    DTBL1(N1,N2,3)=BTBL3(N1,N2)
  16908. C    DTBL1(N1,N2,4)=BTBL4(N1,N2)
  16909. C    DTBL1(N1,N2,5)=BTBL5(N1,N2)
  16910. C    DTBL1(N1,N2,6)=BTBL6(N1,N2)
  16911. C    DTBL1(N1,N2,7)=BTBL7(N1,N2)
  16912. C    DTBL1(N1,N2,8)=BTBL8(N1,N2)
  16913. C3    DTBL1(N1,N2,1)=BTBL1(N1,N2)
  16914.     DO 4 N=1,9
  16915.     VLEN(N)=BVLEN(N)
  16916. 4    CONTINUE
  16917.     DO 5 N2=1,3
  16918.     DO 5 N1=1,16
  16919.     DIGITS(N1,N2)=BIGITS(N1,N2)
  16920. 5    CONTINUE
  16921. C SET UP DEFAULT DISPLAY FORMAT (INCLUDES "(" AND ")" CHARS WHICH
  16922. C ***MUST*** BE THERE FOR MAIN PGM TO WORK).
  16923.     DO 17 N=1,12
  16924.     DVFMT(N)=BVFMT(N)
  16925. 17    Continue
  16926.     DO 15 N=1,26
  16927.     QAC(N)=0.
  16928. 15    CONTINUE
  16929.     DO 18 N=1,8
  16930.     QDERIV(N)=1.
  16931.     ACV(N)=0
  16932.     QDEL(N)=0.
  16933.     QCENT(N)=0
  16934. 18    CONTINUE
  16935.     QOLDVV=1.
  16936.     QCAC=1
  16937.     OSWIT=0
  16938.     OCNTR=0
  16939.     ILNFG=0
  16940.     ILNCT=0
  16941.     IC1POS=0
  16942.     IC2POS=0
  16943.     RETURN
  16944.     END
  16945. c -h- dtrcmd.for    Fri Aug 22 13:04:33 1986    
  16946. C DATATRIEVE INTERFACE FUNCTIONS
  16947. C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
  16948. C
  16949. C THIS IS THE NON-DTR VERSION with dummy entry points for
  16950. C the DTR functions BUT supplying the new non-DTR functions
  16951. c completely.
  16952.     SUBROUTINE DTRCMD(LINE)
  16953.     CHARACTER*1 LINE(80)
  16954.     CHARACTER*62 LINEC
  16955. C    EQUIVALENCE(LINEC(1:1),LINE(1))
  16956. C    INCLUDE 'VKLUGPRM.FTN'
  16957. C COPYRIGHT (C) 1983 GLENN EVERHART
  16958.     INTEGER RETCD
  16959. C
  16960. C DEFINE FILE AREAS FOR MAPPING FILES...
  16961. C ONE INPUT FILE, TO BE ACCESSED AS A RANDOM ACCESS FILE OF 128 BYTE
  16962. C RECORDS OF DATA IF RANDOM, OR AS A FORMULA FILE IF SEQUENTIAL, AND
  16963. C ONE OUTPUT FILE TO BE WRITTEN THE SAME WAY. INPUT FILE CAN BE
  16964. C INPUT - ONLY OR READ/WRITE.
  16965. C
  16966. C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
  16967. C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
  16968. C
  16969. C MFIOPN =    0    IF NOT OPEN
  16970. C        1    IF OPEN FOR READ ONLY, SEQUENTIAL
  16971. C        2    IF OPEN READ ONLY, RANDOM
  16972. C        3    IF OPEN READ/WRITE, RANDOM.
  16973. C
  16974. C MFOOPN =    0    IF NOT OPEN
  16975. C        1    IF OPEN WRITE SEQUENTIAL
  16976. C        2    IF OPEN WRITE RANDOM
  16977. C
  16978. C OTHER OPTIONS DON'T MAKE SENSE.
  16979. C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
  16980. C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
  16981. C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
  16982. C MFILUN,MFOLUN ARE LOGICAL UNITS.
  16983.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  16984.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  16985.  
  16986.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  16987.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  16988.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  16989. C
  16990. C
  16991.     CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
  16992.     InTeGer*4 TYPE(1,1),VLEN(9)
  16993.     REAL*8 XAC,XVBLS(1,1)
  16994.     REAL*8 TAC,UAC,VAC,WAC,YAC
  16995.     REAL*8 TMP
  16996.     INTEGER*4 JVBLS(2,1,1)
  16997.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  16998.     EQUIVALENCE(XAC,AVBLS(1,27))
  16999.     EQUIVALENCE(TAC,AVBLS(1,20))
  17000.     EQUIVALENCE(UAC,AVBLS(1,21))
  17001.     EQUIVALENCE(VAC,AVBLS(1,22))
  17002.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  17003.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  17004.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  17005. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  17006. CCC    CHARACTER*1 XTNCMD(80)
  17007. C ***<<<< RDD COMMON START >>>***
  17008.     InTeGer*4 RRWACT,RCLACT
  17009. C    COMMON/RCLACT/RRWACT,RCLACT
  17010.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  17011.      1  IDOL7,IDOL8
  17012. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  17013. C     1  IDOL7,IDOL8
  17014.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  17015. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  17016.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  17017. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  17018. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  17019. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  17020.     InTeGer*4 KLVL
  17021. C    COMMON/KLVL/KLVL
  17022.     InTeGer*4 IOLVL,IGOLD
  17023. C    COMMON/IOLVL/IOLVL
  17024. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  17025. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  17026.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  17027.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  17028.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  17029.      3  k3dfg,kcdelt,krdelt,kpag
  17030. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  17031. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  17032. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  17033. C ***<<< RDD COMMON END >>>***
  17034. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  17035. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  17036. CCC    InTeGer*4 RRWACT,RCLACT
  17037. CCC    COMMON/RCLACT/RRWACT,RCLACT
  17038. C ***<<< XVXTCD COMMON START >>>***
  17039.     CHARACTER*1 OARRY(100)
  17040.     InTeGer*4 OSWIT,OCNTR
  17041. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  17042. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  17043.     InTeGer*4 IPS1,IPS2,MODFLG
  17044. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  17045.        InTeGer*4 XTCFG,IPSET,XTNCNT
  17046.        CHARACTER*1 XTNCMD(80)
  17047. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  17048. C VARY FLAG ITERATION COUNT
  17049.     INTEGER KALKIT
  17050. C    COMMON/VARYIT/KALKIT
  17051.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  17052.     InTeGer*4 RCMODE,IRCE1,IRCE2
  17053. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  17054. C     1  IRCE2
  17055. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  17056. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  17057. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  17058. C RCFGX ON.
  17059. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  17060. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  17061. C  AND VM INHIBITS. (SETS TO 1).
  17062.     INTEGER*4 FH
  17063. C FILE HANDLE FOR CONSOLE I/O (RAW)
  17064. C    COMMON/CONSFH/FH
  17065.     CHARACTER*1 ARGSTR(52,4)
  17066. C    COMMON/ARGSTR/ARGSTR
  17067.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  17068.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  17069.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  17070.      3  IRCE2,FH,ARGSTR
  17071. C ***<<< XVXTCD COMMON END >>>***
  17072. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  17073. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  17074. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  17075. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  17076. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  17077. C (IMPLEMENT FOR VAX ONLY)
  17078. CCC    INTEGER KALKIT
  17079. CCC    COMMON/VARYIT/KALKIT
  17080. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  17081. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  17082. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  17083. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  17084.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  17085.     COMMON/D2R/NRDSP,NCDSP
  17086. C ***<<< KLSTO COMMON START >>>***
  17087.     InTeGer*4 DLFG
  17088. C    COMMON/DLFG/DLFG
  17089.     InTeGer*4 KDRW,KDCL
  17090. C    COMMON/DOT/KDRW,KDCL
  17091.     InTeGer*4 DTRENA
  17092. C    COMMON/DTRCMN/DTRENA
  17093.     REAL*8 EP,PV,FV
  17094.     DIMENSION EP(20)
  17095.     INTEGER*4 KIRR
  17096. C    COMMON/ERNPER/EP,PV,FV,KIRR
  17097.     InTeGer*4 LASTOP
  17098. C    COMMON/ERROR/LASTOP
  17099.     CHARACTER*1 FMTDAT(9,76)
  17100. C    COMMON/FMTBFR/FMTDAT
  17101.     CHARACTER*1 EDNAM(16)
  17102. C    COMMON/EDNAM/EDNAM
  17103.     InTeGer*4 MFID(2),MFMOD(2)
  17104. C    COMMON/FRM/MFID,MFMOD
  17105.     InTeGer*4 JMVFG,JMVOLD
  17106. C    COMMON/FUBAR/JMVFG,JMVOLD
  17107.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  17108.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  17109. C ***<<< KLSTO COMMON END >>>***
  17110. CCC    InTeGer*4 DTRENA
  17111. CCC    COMMON/DTRCMN/DTRENA
  17112.     CHARACTER *1 LINECL(82)
  17113. C    CHARACTER*70 LINEC
  17114.     EQUIVALENCE(LINEC(1:1),LINECL(1))
  17115. C    CHARACTER*80 SCRBUF
  17116.     CHARACTER*1 LBUF(128)
  17117.     CHARACTER*1 MBUF(128)
  17118.     CHARACTER*110 CLBUF,CMBUF
  17119.     CHARACTER*50 CCLBUF,CCMBUF
  17120.     CHARACTER*11 C11LBF
  17121. C    EQUIVALENCE(C11LBF(1:1),CLBUF(1:1))
  17122.     EQUIVALENCE(CLBUF(1:1),CCLBUF(1:1),LBUF(1),C11LBF(1:1)),
  17123.      1  (CMBUF(1:1),CCMBUF(1:1),MBUF(1))
  17124. C    EQUIVALENCE(CLBUF,LBUF(1)),(CMBUF,MBUF(1))
  17125. C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
  17126.     CHARACTER*9 FMTB
  17127.     EQUIVALENCE (FMTB(1:1),LBUF(120))
  17128.     CHARACTER*11 FMTBF
  17129.     CHARACTER*1 IFVLD
  17130. C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
  17131. ccc    DO 3332 N=1,80
  17132. ccc    NN=81-N
  17133. ccc    IF(ICHAR(LINE(NN)).GT.32)GOTO 3333
  17134. ccc    LINE(NN)=CHAR(0)
  17135. ccc3332    CONTINUE
  17136. ccc3333    CONTINUE
  17137. C SPACE FILL ENTIRE ARRAY
  17138.     DO 3334 N=1,82
  17139. 3334    LINECL(N)=CHAR(32)
  17140.     RETCD=1
  17141. C HANDLE DTRCMD FUNCTIONS. LINE ARRAY PASSED IN HERE
  17142. C STARTS AFTER THE "DTR" SO WE CAN DECODE IT.
  17143. C EXECUTE DTR COMMAND
  17144. C  DTRCMD (COMMAND) GIVES DTR COMMAND FACILITY AT COMMAND
  17145. C LEVEL.
  17146. C ALLOW DTRIMM COMMAND TO USE DTR IMMEDIATE TERMINAL
  17147. C INTERFACE. THE REST CAN USE SAME COMMAND NAMES AS AFTER
  17148. C THE "DB" IN *U DBXXXX COMMANDS.
  17149. 500    CONTINUE
  17150. C ENABLE/DISABLE FOR DTR FUNCTIONS
  17151. C SETTING DTRENA TO -1 IMPLIES DISABLE FUNCTIONS
  17152.     CALL SCMP(LINE,'ENA',3,ICODE)
  17153.     IF(ICODE.NE.1)GOTO 600
  17154.     DTRENA=1
  17155.     GOTO 9999
  17156. 600    CONTINUE
  17157.     CALL SCMP(LINE,'DIS',3,ICODE)
  17158.     IF(ICODE.NE.1)GOTO 700
  17159.     DTRENA=-1
  17160.     GOTO 9999
  17161. 700    CONTINUE
  17162.     CALL SCMP(LINE,'OPINS',5,ICODE)
  17163. C OPEN INPUT SEQUENTIAL
  17164.     IF(ICODE.NE.1)GOTO 3800
  17165. C DTROPINS RANGE FILENAME
  17166.     IBGN=6
  17167.     IVLD=0
  17168.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  17169.     IF(IVLD.EQ.3)GOTO 9990
  17170.     LINE(LSTCH+25)=CHAR(0)
  17171.     OPEN(UNIT=MFILUN,FILE=LINE(LSTCH),ACCESS='SEQUENTIAL',
  17172.      1  STATUS='OLD',IOSTAT=IVVV)
  17173.     IF(IVVV.NE.0)GOTO 9990
  17174.     MFIOPN=1
  17175.     GOTO 9999
  17176. 3800    CONTINUE
  17177.     CALL SCMP(LINE,'OPINRR',6,ICODE)
  17178. C OPEN IN RANDOM READ
  17179.     IF(ICODE.NE.1)GOTO 3900
  17180.     KK=2
  17181.     GOTO 3910
  17182. 3900    CONTINUE
  17183.     CALL SCMP(LINE,'OPINRU',6,ICODE)
  17184. C OPEN IN RANDOM UPDATE
  17185.     IF(ICODE.NE.1)GOTO 3950
  17186.     KK=3
  17187. 3910    CONTINUE
  17188. C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W
  17189.     IBGN=7
  17190.     IVLD=0
  17191.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  17192.     IF(IVLD.EQ.3)GOTO 9990
  17193. C *******
  17194. C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
  17195.     DO 5601 NN=1,50
  17196. 5601    MBUF(NN)=' '
  17197.     DO 5602 NN=1,25
  17198. 5602    MBUF(NN)=LINE(LSTCH+NN-1)
  17199. C    LINE(LSTCH+25)=0
  17200. C    NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
  17201. C    OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='BINARY',
  17202. C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='OLD',
  17203. C     1  RECL=128,BLOCKSIZE=128,ERR=9990)
  17204.     OPEN(UNIT=MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  17205.      1  STATUS='OLD',FORM='UNFORMATTED',RECL=128,
  17206.      1  IOSTAT=IVVV)
  17207.     IF(IVVV.NE.0)GOTO 9990
  17208.     MFIOPN=KK
  17209.     GOTO 9999
  17210. 3950    CONTINUE
  17211.     CALL SCMP(LINE,'OPOUTS',6,ICODE)
  17212. C OPEN OUTPUT SEQUENTIAL
  17213.     IF(ICODE.NE.1)GOTO 4000
  17214.     IBGN=7
  17215.     IVLD=0
  17216.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  17217.     IF(IVLD.EQ.3)GOTO 9990
  17218. C *******
  17219. C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
  17220. C    LINE(LSTCH+25)=0
  17221.     DO 5603 NN=1,50
  17222. 5603    MBUF(NN)=' '
  17223.     DO 5604 NN=1,25
  17224. 5604    MBUF(NN)=LINE(LSTCH+NN-1)
  17225.     OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='SEQUENTIAL',
  17226.      1  STATUS='NEW',IOSTAT=IVVV)
  17227.     IF(IVVV.NE.0)GOTO 9990
  17228.     MFOOPN=1
  17229.     GOTO 9999
  17230. 4000    CONTINUE
  17231.     CALL SCMP(LINE,'OPOUTR',6,ICODE)
  17232. C OPEN OUTPUT RANDOM
  17233.     IF(ICODE.NE.1)GOTO 4100
  17234.     IBGN=7
  17235.     IVLD=0
  17236.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  17237.     IF(IVLD.EQ.3)GOTO 9990
  17238. C    NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
  17239. C *******
  17240. C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
  17241.     DO 5605 NN=1,50
  17242. 5605    MBUF(NN)=' '
  17243.     DO 5606 NN=1,25
  17244. 5606    MBUF(NN)=LINE(LSTCH+NN-1)
  17245. C    LINE(LSTCH+25)=0
  17246. C    OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  17247. C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='NEW',
  17248. C     1  RECL=32,BLOCKSIZE=128,ERR=9990)
  17249.     OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='DIRECT',
  17250.      1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
  17251.      2  IOSTAT=IVVV)
  17252.     IF(IVVV.NE.0)GOTO 9990
  17253.     MFOOPN=2
  17254.     GOTO 9999
  17255. 4100    CONTINUE
  17256.     CALL SCMP(LINE,'CLSOUT',6,ICODE)
  17257. C CLOSE OUTPUT 
  17258.     IF(ICODE.NE.1)GOTO 4200
  17259.     CLOSE(UNIT=MFOLUN)
  17260.     MFOOPN=0
  17261.     GOTO 9999
  17262. 4200    CONTINUE
  17263.     CALL SCMP(LINE,'CLSINP',6,ICODE)
  17264. C CLOSE INPUT 
  17265.     IF(ICODE.NE.1)GOTO 4300
  17266.     CLOSE(UNIT=MFILUN)
  17267.     MFIOPN=0
  17268.     GOTO 9999
  17269. 4300    CONTINUE
  17270.     CALL SCMP(LINE,'ENAOUT',6,ICODE)
  17271. C ENABLE OUTPUT 
  17272.     IF(ICODE.NE.1)GOTO 4400
  17273.     MFOFLG=1
  17274.     GOTO 9999
  17275. 4400    CONTINUE
  17276.     CALL SCMP(LINE,'ENAINP',6,ICODE)
  17277. C ENABLE INPUT 
  17278.     IF(ICODE.NE.1)GOTO 4500
  17279.     MFIFLG=1
  17280.     GOTO 9999
  17281. 4500    CONTINUE
  17282.     CALL SCMP(LINE,'DISINP',6,ICODE)
  17283. C DISABLE INPUT 
  17284.     IF(ICODE.NE.1)GOTO 4510
  17285.     MFIFLG=0
  17286.     GOTO 9999
  17287. 4510    CONTINUE
  17288.     CALL SCMP(LINE,'DISOUT',6,ICODE)
  17289. C DISABLE OUTPUT
  17290.     IF(ICODE.NE.1)GOTO 4520
  17291.     MFOFLG=0
  17292.     GOTO 9999
  17293. 4520    CONTINUE
  17294.     CALL SCMP(LINE,'EDTINP',6,ICODE)
  17295. C ENABLE INPUT FORCE
  17296. C COMMAND
  17297. C DTREDTINP RANGE
  17298. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  17299. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  17300. C IT OUT AGAIN.
  17301.     IF(ICODE.NE.1)GOTO 4600
  17302. C FORCE ENABLE OF READIN DURING THIS
  17303.     MFIFLG=1
  17304.     MFOFLG=1
  17305. C ENABLE OUTPUT TOO.
  17306.     IBGN=7
  17307.     IVLD=0
  17308.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17309.     IF(IVLD.EQ.3)GOTO 9990
  17310.     DO 4550 N1=IXRL,IXRH
  17311.     DO 4550 N2=IXCL,IXCH
  17312.     CALL REFLEC(N2,N1,IRX)
  17313. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  17314.     CALL FVLDST(N1,N2,Char(255))
  17315.     CALL WRKFIL(IRX,LBUF,0)
  17316.     CALL WRKFIL(IRX,LBUF,1)
  17317. 4550    CONTINUE
  17318.     MFIFLG=0
  17319.     MFOFLG=0
  17320.     GOTO 9999
  17321. 4600    CONTINUE
  17322.     CALL SCMP(LINE,'FMTOUT',6,ICODE)
  17323. C FORMAT/WRITE OUTPUT
  17324. C COMMAND
  17325. C DTRFMTOUT RANGE
  17326. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  17327. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  17328. C IT OUT AGAIN.
  17329.     IF(ICODE.NE.1)GOTO 4630
  17330.     IVLFG=1
  17331.     GOTO 4740
  17332. 4630    CONTINUE
  17333.     CALL SCMP(LINE,'VALOUT',6,ICODE)
  17334.     IF(ICODE.NE.1)GOTO 4700
  17335. C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
  17336.     IVFLG=2
  17337. C    GOTO 4740
  17338. 4740    CONTINUE
  17339. C FORCE ENABLE OF READIN DURING THIS
  17340.     MFIFLG=1
  17341.     MFOFLG=1
  17342. C ENABLE OUTPUT TOO.
  17343.     IBGN=7
  17344.     IVLD=0
  17345.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17346.     IF(IVLD.EQ.3)GOTO 9990
  17347.     DO 4650 N1=IXRL,IXRH
  17348.     DO 4650 N2=IXCL,IXCH
  17349. C FIND INDEX FOR WRKFIL
  17350.     CALL REFLEC(N2,N1,IRX)
  17351. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  17352.     CALL XVBLGT(N1,N2,TMP)
  17353. C TMP IS REAL*8 SCRATCH
  17354.     CALL FVLDST(N1,N2,Char(255))
  17355.     CALL WRKFIL(IRX,LBUF,0)
  17356. C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
  17357. C NOW GRAB THE VALUE AND SAVE IT...
  17358. C FIRST MOVE THE FORMAT DOWN
  17359. C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
  17360.     DO 4651 N=1,9
  17361.     LBUF(N+1)=LBUF(N+119)
  17362. 4651    CONTINUE
  17363.     LBUF(1)='('
  17364.     LBUF(11)=')'
  17365. c    LBUF(12)=CHAR(0)
  17366. C CHANGE TO USE CHAR VERSION OF LBUF
  17367. C *******
  17368. C FORMAT NOW LIVES IN LOW PART OF LBUF
  17369. C D25.17 FORMAT WOULD DO FOR WRITE
  17370. c    IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF(1:11),ERR=4652)TMP
  17371.     IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF,ERR=4652)TMP
  17372.     IF(IVLFG.EQ.2)WRITE(LINEC(1:70),4658,ERR=4652)TMP
  17373. 4658    FORMAT(D25.17)
  17374. C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
  17375. C USE DISPLAY FORMAT.
  17376. 4652    CONTINUE
  17377.     KK=1
  17378.     DO 4653 N=1,110
  17379. 4653    LBUF(N)=CHAR(0)
  17380.     DO 4654 N=1,60
  17381. C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
  17382.     KKK=JCHAR(LINECL(N))
  17383.     IF(KKK.LE.32)GOTO 4654
  17384.     LBUF(KK)=LINECL(N)
  17385.     KK=KK+1
  17386. 4654    CONTINUE
  17387.     CALL WRKFIL(IRX,LBUF,1)
  17388. 4650    CONTINUE
  17389.     MFIFLG=0
  17390.     MFOFLG=0
  17391.     GOTO 9999
  17392. 4700    CONTINUE
  17393.     CALL SCMP(LINE,'CMPFRM',6,ICODE)
  17394.     IF(ICODE.NE.1)GOTO 4800
  17395. C DBCMPFRM V1:V2
  17396. C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
  17397.     IBGN=7
  17398.     IVLD=0
  17399. C USE GMTX TO GET CELL ADDRESSES.
  17400.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17401.     IF(IVLD.EQ.3)GOTO 9990
  17402. C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
  17403.     CALL REFLEC(IXCL,IXRL,IRXL)
  17404.     CALL REFLEC(IXCH,IXRH,IRXH)
  17405.     IF(LINE(LSTCH).NE.',')GOTO 4780
  17406.     IBGN=LSTCH+1
  17407.     IVLD=0
  17408.     CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
  17409.     IF(IVLD.EQ.3)GOTO 4780
  17410. C GET THE LENGTHS NOW
  17411.     CALL XVBLGT(IYRL,IYCL,TMP)
  17412.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  17413.     LBUFL=TMP
  17414.     CALL XVBLGT(IYRH,IYCH,TMP)
  17415.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  17416.     MBUFL=TMP
  17417. C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
  17418. C COMPARISONS BASED ON THAT.
  17419.     GOTO 4770
  17420. 4780    CONTINUE
  17421. C GET INDEX OF EACH ELEMENT...
  17422.     CALL WRKFIL(IRXL,LBUF,0)
  17423.     CALL WRKFIL(IRXH,MBUF,0)
  17424. C LOAD THE 2 FORMULAS.
  17425. C NOW FIND THE ENDS...
  17426.     DO 4750 N=1,110
  17427.     NN=111-N
  17428.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
  17429. 4750    CONTINUE
  17430. 4751    LBUFL=NN
  17431.     DO 4760 N=1,110
  17432.     NN=111-N
  17433.     IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
  17434. 4760    CONTINUE
  17435. 4761    MBUFL=NN
  17436. 4770    CONTINUE
  17437. c find index pos'n by hand...
  17438.     KK=LBUFL-MBUFL+1
  17439.     DO 4776 NN=1,KK
  17440.     IF(LBUF(NN).NE.MBUF(1))GOTO 4776
  17441.     NNN=MBUFL-1
  17442.     DO 4777 N=1,NNN
  17443.     IVVV=NN+N
  17444.     IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
  17445. 4777    CONTINUE
  17446. C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
  17447. C SINCE NN IS WHAT WE NEED, GO USE IT.
  17448.     GOTO 4779
  17449. 4778    CONTINUE
  17450. 4776    CONTINUE
  17451. C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
  17452. C
  17453.     NN=0
  17454. 4779    CONTINUE
  17455. C NN IS LOCATION OF SUBSTRING NOW
  17456. C    NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
  17457. C NN IS LOCATION OF SUBSTRING NOW
  17458.     XAC=NN
  17459. C RETURN RESULT IN % ACCUMULATOR.
  17460.     WAC=0.
  17461.     IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
  17462.     IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
  17463. C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
  17464. C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
  17465. C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
  17466.     GOTO 9999
  17467. 4800    CONTINUE
  17468.     CALL SCMP(LINE,'LENFRM',6,ICODE)
  17469.     IF(ICODE.NE.1)GOTO 4900
  17470. C DBLENFRM V1:V2
  17471. C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
  17472.     IBGN=7
  17473.     IVLD=0
  17474. C USE GMTX TO GET CELL ADDRESSES.
  17475.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17476.     IF(IVLD.EQ.3)GOTO 9990
  17477. C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
  17478.     CALL REFLEC(IXCL,IXRL,IRXL)
  17479. C GET INDEX OF EACH ELEMENT...
  17480.     CALL WRKFIL(IRXL,LBUF,0)
  17481. C LOAD THE FORMULA.
  17482. C NOW FIND THE END...
  17483.     DO 4850 N=1,110
  17484.     NN=111-N
  17485.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
  17486. 4850    CONTINUE
  17487. 4851    LBUFL=NN
  17488.     TMP=LBUFL
  17489.     XAC=TMP
  17490. C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
  17491.     NN=0
  17492. C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
  17493.     CALL FVLDGT(IXRH,IXCH,NN)
  17494.     IF(NN.EQ.0)GOTO 9999
  17495.     CALL XVBLST(IXRH,IXCH,TMP)
  17496.     GOTO 9999
  17497. 4900    CONTINUE
  17498.     CALL SCMP(LINE,'TRMFRM',6,ICODE)
  17499.     IF(ICODE.NE.1)GOTO 5000
  17500. C TRIM FORMULA
  17501. C DTRTRMFRM INCELL:OUTCELL,START:END
  17502. C RETURNS TRIMMED FORMULA TO CELL.
  17503.     IBGN=7
  17504.     IVLD=0
  17505. C USE GMTX TO GET CELL ADDRESSES.
  17506.     CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
  17507.     IF(IVLD.EQ.3)GOTO 9990
  17508. C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
  17509.     CALL REFLEC(IXCL,IXRL,IRXL)
  17510. C GET INDEX OF EACH ELEMENT...
  17511.     CALL REFLEC(IXCH,IXRH,IRXH)
  17512.     CALL WRKFIL(IRXL,LBUF,0)
  17513.     LO=LSTCHR+1
  17514.     LHI=LSTCHR+21
  17515.     LSTCHR=LHI
  17516.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  17517.     IF(IVLD.EQ.0)GOTO 9990
  17518.     CALL XVBLGT(JD1,JD2,TMP)
  17519.     LOCHR=1
  17520.     IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
  17521. C LOCHR = START CHAR
  17522.     LO=LSTCHR+1
  17523.     LHI=LSTCHR+21
  17524.     LSTCHR=LHI
  17525.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  17526.     IF(IVLD.EQ.0)GOTO 9990
  17527.     CALL XVBLGT(JD1,JD2,TMP)
  17528.     LHICHR=110
  17529.     IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
  17530. C LHICHR IS END CHARACTER
  17531. C NOW ALL ARGS ARE COLLECTED.
  17532. C (IGNORE WHAT WAS DELIMITER...)
  17533. C COPY DESIRED STUFF TO MBUF
  17534.     N=1
  17535.     DO 4910 NN=1,110
  17536.     MBUF(NN)=CHAR(0)
  17537.     IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
  17538.     MBUF(N)=LBUF(NN)
  17539.     N=N+1
  17540. C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
  17541. 4910    CONTINUE
  17542.     DO 4911 NN=111,128
  17543. 4911    MBUF(NN)=LBUF(NN)
  17544.     CALL WRKFIL(IRXH,MBUF,1)
  17545. C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
  17546. C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
  17547.     GOTO 9999
  17548. 5000    CONTINUE
  17549.     GOTO 9999
  17550. 9990    RETCD=3
  17551. C ERROR RETURN
  17552. 9999    RETURN
  17553.     END
  17554. c -h- dtrfct.for    Fri Aug 22 13:05:02 1986    
  17555. C DATATRIEVE INTERFACE FUNCTIONS
  17556. C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
  17557. C COPYRIGHT 1986 GCE
  17558.     SUBROUTINE DTRFCT(LINE,RETCD)
  17559.     InTeGer*4 RETCD
  17560.     CHARACTER*1 LINE(80)
  17561.     CHARACTER *1 LINECL(82)
  17562.     CHARACTER*62 LINEC
  17563.     EQUIVALENCE(LINEC(1:1),LINECL(1))
  17564. C
  17565. C
  17566. C DEFINE FILE AREAS FOR MAPPING FILES...
  17567. C
  17568. C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
  17569. C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
  17570. C
  17571. C MFIOPN =    0    IF NOT OPEN
  17572. C        1    IF OPEN FOR READ ONLY, SEQUENTIAL
  17573. C        2    IF OPEN READ ONLY, RANDOM
  17574. C        3    IF OPEN READ/WRITE, RANDOM.
  17575. C
  17576. C MFOOPN =    0    IF NOT OPEN
  17577. C        1    IF OPEN WRITE SEQUENTIAL
  17578. C        2    IF OPEN WRITE RANDOM
  17579. C
  17580. C OTHER OPTIONS DON'T MAKE SENSE.
  17581. C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
  17582. C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
  17583. C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
  17584. C MFILUN,MFOLUN ARE LOGICAL UNITS.
  17585.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  17586.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  17587.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  17588.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  17589.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  17590. C
  17591. C
  17592. C    INCLUDE 'VKLUGPRM.FTN'
  17593. C COPYRIGHT (C) 1983 GLENN EVERHART
  17594. C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS
  17595. C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY.
  17596.     CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
  17597.     InTeGer*4 TYPE(1,1),VLEN(9)
  17598.     REAL*8 XAC,XVBLS(1,1)
  17599.     REAL*8 TAC,UAC,VAC,WAC,YAC
  17600.     REAL*8 TMP
  17601.     INTEGER*4 JVBLS(2,1,1)
  17602.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  17603.     EQUIVALENCE(XAC,AVBLS(1,27))
  17604.     EQUIVALENCE(TAC,AVBLS(1,20))
  17605.     EQUIVALENCE(UAC,AVBLS(1,21))
  17606.     EQUIVALENCE(VAC,AVBLS(1,22))
  17607.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  17608.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  17609.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  17610. C ***<<<< RDD COMMON START >>>***
  17611.     InTeGer*4 RRWACT,RCLACT
  17612. C    COMMON/RCLACT/RRWACT,RCLACT
  17613.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  17614.      1  IDOL7,IDOL8
  17615. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  17616. C     1  IDOL7,IDOL8
  17617.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  17618. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  17619.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  17620. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  17621. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  17622. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  17623.     InTeGer*4 KLVL
  17624. C    COMMON/KLVL/KLVL
  17625.     InTeGer*4 IOLVL,IGOLD
  17626. C    COMMON/IOLVL/IOLVL
  17627. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  17628. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  17629.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  17630.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  17631.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  17632.      3  k3dfg,kcdelt,krdelt,kpag
  17633. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  17634. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  17635. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  17636. C ***<<< RDD COMMON END >>>***
  17637. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  17638. CCC    CHARACTER*1 XTNCMD(80)
  17639. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  17640. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  17641. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  17642. CCC    InTeGer*4 RRWACT,RCLACT
  17643. CCC    COMMON/RCLACT/RRWACT,RCLACT
  17644. C ***<<< XVXTCD COMMON START >>>***
  17645.     CHARACTER*1 OARRY(100)
  17646.     InTeGer*4 OSWIT,OCNTR
  17647. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  17648. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  17649.     InTeGer*4 IPS1,IPS2,MODFLG
  17650. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  17651.        InTeGer*4 XTCFG,IPSET,XTNCNT
  17652.        CHARACTER*1 XTNCMD(80)
  17653. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  17654. C VARY FLAG ITERATION COUNT
  17655.     INTEGER KALKIT
  17656. C    COMMON/VARYIT/KALKIT
  17657.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  17658.     InTeGer*4 RCMODE,IRCE1,IRCE2
  17659. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  17660. C     1  IRCE2
  17661. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  17662. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  17663. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  17664. C RCFGX ON.
  17665. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  17666. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  17667. C  AND VM INHIBITS. (SETS TO 1).
  17668.     INTEGER*4 FH
  17669. C FILE HANDLE FOR CONSOLE I/O (RAW)
  17670. C    COMMON/CONSFH/FH
  17671.     CHARACTER*1 ARGSTR(52,4)
  17672. C    COMMON/ARGSTR/ARGSTR
  17673.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  17674.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  17675.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  17676.      3  IRCE2,FH,ARGSTR
  17677. C ***<<< XVXTCD COMMON END >>>***
  17678. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  17679. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  17680. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  17681. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  17682. C (IMPLEMENT FOR VAX ONLY)
  17683.     INTEGER IVVV
  17684. CCC    COMMON/VARYIT/KALKIT
  17685. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  17686. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  17687. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  17688. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  17689.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  17690.     COMMON/D2R/NRDSP,NCDSP
  17691. C ***<<< KLSTO COMMON START >>>***
  17692.     InTeGer*4 DLFG
  17693. C    COMMON/DLFG/DLFG
  17694.     InTeGer*4 KDRW,KDCL
  17695. C    COMMON/DOT/KDRW,KDCL
  17696.     InTeGer*4 DTRENA
  17697. C    COMMON/DTRCMN/DTRENA
  17698.     REAL*8 EP,PV,FV
  17699.     DIMENSION EP(20)
  17700.     INTEGER*4 KIRR
  17701. C    COMMON/ERNPER/EP,PV,FV,KIRR
  17702.     InTeGer*4 LASTOP
  17703. C    COMMON/ERROR/LASTOP
  17704.     CHARACTER*1 FMTDAT(9,76)
  17705. C    COMMON/FMTBFR/FMTDAT
  17706.     CHARACTER*1 EDNAM(16)
  17707. C    COMMON/EDNAM/EDNAM
  17708.     InTeGer*4 MFID(2),MFMOD(2)
  17709. C    COMMON/FRM/MFID,MFMOD
  17710.     InTeGer*4 JMVFG,JMVOLD
  17711. C    COMMON/FUBAR/JMVFG,JMVOLD
  17712.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  17713.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  17714. C ***<<< KLSTO COMMON END >>>***
  17715. CCC    InTeGer*4 DTRENA
  17716. CCC    COMMON/DTRCMN/DTRENA
  17717. C    CHARACTER*70 LINEC
  17718.     CHARACTER*1 LBUF(128)
  17719.     CHARACTER*1 MBUF(128)
  17720.     CHARACTER*110 CLBUF,CMBUF
  17721. C    EQUIVALENCE(CLBUF(1:1),LBUF(1)),(CMBUF(1:1),MBUF(1))
  17722.     CHARACTER*50 CCMBUF
  17723.     CHARACTER*11 C11LBF
  17724.     EQUIVALENCE(CCMBUF(1:1),CMBUF(1:1),MBUF(1)),
  17725.      1  (C11LBF(1:1),CLBUF(1:1),LBUF(1))
  17726. C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
  17727. c    CHARACTER*1 IFVLD
  17728.     RETCD=1
  17729.     IF(DTRENA.LT.0)GOTO 9999
  17730. C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
  17731. ccc    DO 3332 N=1,76
  17732. ccc    NN=77-N
  17733. ccc    IF(JCHAR(LINE(NN)).GT.32)GOTO 3333
  17734. ccc    LINE(NN)=CHAR(0)
  17735. ccc3332    CONTINUE
  17736. ccc3333    CONTINUE
  17737. C SPACE FILL ENTIRE ARRAY
  17738.     DO 3334 N=1,82
  17739. 3334    LINECL(N)=CHAR(32)
  17740.     RETCD=1
  17741. C HANDLE *U DBXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
  17742. C STARTS AFTER THE "DB" SO WE CAN DECODE IT.
  17743. C *U DBCMD (COMMAND) PASSES COMMAND TO DTR FOR ACTION
  17744. C  HOWEVER THIS DOES NOT RETURN A VALUE. USE FOR
  17745. C  SETUP PURPOSES ONLY.
  17746. C
  17747. C NO NEED TO INCLUDE ABILITY TO STORE COMMANDS IN CELLS
  17748. C FOR EDITING SINCE {CELL CONSTRUCT PROVIDES THIS ALREADY.
  17749. C (AND AT COMMAND LEVEL THE __{CELL CONSTRUCT DOES ALSO.)
  17750. 500    CONTINUE
  17751.     CALL SCMP(LINE,'OPINS',5,ICODE)
  17752. C OPEN INPUT SEQUENTIAL
  17753.     IF(ICODE.NE.1)GOTO 3800
  17754. C DTROPINS RANGE FILENAME
  17755.     IBGN=6
  17756.     IVLD=0
  17757.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  17758.     IF(IVLD.EQ.3)GOTO 9990
  17759. C    LINE(LSTCH+25)=CHAR(0)
  17760.     DO 5601 NN=1,50
  17761. 5601    MBUF(NN)=' '
  17762.     DO 5602 NN=1,25
  17763. 5602    MBUF(NN)=LINE(LSTCH+NN-1)
  17764.     OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
  17765.      1  STATUS='OLD',IOSTAT=IVVV)
  17766.     IF(IVVV.NE.0)GOTO 9990
  17767.     MFIOPN=1
  17768.     GOTO 9999
  17769. 3800    CONTINUE
  17770.     CALL SCMP(LINE,'OPINRR',6,ICODE)
  17771. C OPEN IN RANDOM READ
  17772.     IF(ICODE.NE.1)GOTO 3900
  17773.     KK=2
  17774.     GOTO 3910
  17775. 3900    CONTINUE
  17776.     CALL SCMP(LINE,'OPINRU',6,ICODE)
  17777. C OPEN IN RANDOM UPDATE
  17778.     IF(ICODE.NE.1)GOTO 3950
  17779.     KK=3
  17780. 3910    CONTINUE
  17781. C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W
  17782.  
  17783.     IBGN=7
  17784.     IVLD=0
  17785.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  17786.     IF(IVLD.EQ.3)GOTO 9990
  17787. C    LINE(LSTCH+25)=0
  17788.     DO 5603 NN=1,50
  17789. 5603    MBUF(NN)=' '
  17790.     DO 5604 NN=1,25
  17791. 5604    MBUF(NN)=LINE(LSTCH+NN-1)
  17792. C    NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
  17793.     OPEN(MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  17794.      1  FORM='UNFORMATTED',RECL=128,STATUS='OLD',IOSTAT=IVVV)
  17795.     IF(IVVV.NE.0)GOTO 9990
  17796.     MFIOPN=KK
  17797.     GOTO 9999
  17798. 3950    CONTINUE
  17799.     CALL SCMP(LINE,'OPOUTS',6,ICODE)
  17800. C OPEN OUTPUT SEQUENTIAL
  17801.     IF(ICODE.NE.1)GOTO 4000
  17802.     IBGN=7
  17803.     IVLD=0
  17804.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  17805.     IF(IVLD.EQ.3)GOTO 9990
  17806.     DO 5605 NN=1,50
  17807. 5605    MBUF(NN)=' '
  17808.     DO 5606 NN=1,25
  17809. 5606    MBUF(NN)=LINE(LSTCH+NN-1)
  17810.     OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
  17811.      1  STATUS='NEW',IOSTAT=IVVV)
  17812.     IF(IVVV.NE.0)GOTO 9990
  17813.     MFOOPN=1
  17814.     GOTO 9999
  17815. 4000    CONTINUE
  17816.     CALL SCMP(LINE,'OPOUTR',6,ICODE)
  17817. C OPEN OUTPUT RANDOM
  17818.     IF(ICODE.NE.1)GOTO 4100
  17819.     IBGN=7
  17820.     IVLD=0
  17821.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  17822.     IF(IVLD.EQ.3)GOTO 9990
  17823. C    NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
  17824. C    LINE(LSTCH+25)=0
  17825.     DO 5607 NN=1,50
  17826. 5607    MBUF(NN)=' '
  17827.     DO 5608 NN=1,25
  17828. 5608    MBUF(NN)=LINE(LSTCH+NN-1)
  17829.     OPEN(MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  17830.      1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
  17831.      2  IOSTAT=IVVV)
  17832.     IF(IVVV.NE.0)GOTO 9990
  17833.     MFOOPN=2
  17834.     GOTO 9999
  17835. 4100    CONTINUE
  17836.     CALL SCMP(LINE,'CLSOUT',6,ICODE)
  17837. C CLOSE OUTPUT 
  17838.     IF(ICODE.NE.1)GOTO 4200
  17839.     CLOSE(UNIT=MFOLUN)
  17840.     MFOOPN=0
  17841.     GOTO 9999
  17842. 4200    CONTINUE
  17843.     CALL SCMP(LINE,'CLSINP',6,ICODE)
  17844. C CLOSE INPUT 
  17845.     IF(ICODE.NE.1)GOTO 4300
  17846.     CLOSE(UNIT=MFILUN)
  17847.     MFIOPN=0
  17848.     GOTO 9999
  17849. 4300    CONTINUE
  17850.     CALL SCMP(LINE,'ENAOUT',6,ICODE)
  17851. C ENABLE OUTPUT 
  17852.     IF(ICODE.NE.1)GOTO 4400
  17853.     MFOFLG=1
  17854.     GOTO 9999
  17855. 4400    CONTINUE
  17856.     CALL SCMP(LINE,'ENAINP',6,ICODE)
  17857. C ENABLE INPUT 
  17858.     IF(ICODE.NE.1)GOTO 4500
  17859.     MFIFLG=1
  17860.     GOTO 9999
  17861. 4500    CONTINUE
  17862.     CALL SCMP(LINE,'DISINP',6,ICODE)
  17863. C DISABLE INPUT 
  17864.     IF(ICODE.NE.1)GOTO 4510
  17865.     MFIFLG=0
  17866.     GOTO 9999
  17867. 4510    CONTINUE
  17868.     CALL SCMP(LINE,'DISOUT',6,ICODE)
  17869. C DISABLE OUTPUT
  17870.     IF(ICODE.NE.1)GOTO 4520
  17871.     MFOFLG=0
  17872.     GOTO 9999
  17873. 4520    CONTINUE
  17874.     CALL SCMP(LINE,'EDTINP',6,ICODE)
  17875. C ENABLE INPUT FORCE
  17876. C COMMAND
  17877. C DTREDTINP RANGE
  17878. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  17879. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  17880. C IT OUT AGAIN.
  17881.     IF(ICODE.NE.1)GOTO 4600
  17882. C FORCE ENABLE OF READIN DURING THIS
  17883.     MFIFLG=1
  17884.     MFOFLG=1
  17885. C ENABLE OUTPUT TOO.
  17886.     IBGN=7
  17887.     IVLD=0
  17888.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17889.     IF(IVLD.EQ.3)GOTO 9990
  17890.     DO 4550 N1=IXRL,IXRH
  17891.     DO 4550 N2=IXCL,IXCH
  17892.     CALL REFLEC(N2,N1,IRX)
  17893. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  17894.     CALL FVLDST(N1,N2,Char(255))
  17895.     CALL WRKFIL(IRX,LBUF,0)
  17896.     CALL WRKFIL(IRX,LBUF,1)
  17897. 4550    CONTINUE
  17898.     MFIFLG=0
  17899.     MFOFLG=0
  17900.     GOTO 9999
  17901. 4600    CONTINUE
  17902.     CALL SCMP(LINE,'FMTOUT',6,ICODE)
  17903. C FORMAT/WRITE OUTPUT
  17904. C COMMAND
  17905. C DTRFMTOUT RANGE
  17906. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  17907. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  17908. C IT OUT AGAIN.
  17909.     IF(ICODE.NE.1)GOTO 4630
  17910.     IVLFG=1
  17911.     GOTO 4740
  17912. 4630    CONTINUE
  17913.     CALL SCMP(LINE,'VALOUT',6,ICODE)
  17914.     IF(ICODE.NE.1)GOTO 4700
  17915. C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
  17916.     IVFLG=2
  17917. C    GOTO 4740
  17918. 4740    CONTINUE
  17919. C FORCE ENABLE OF READIN DURING THIS
  17920.     MFIFLG=1
  17921.     MFOFLG=1
  17922. C ENABLE OUTPUT TOO.
  17923.     IBGN=7
  17924.     IVLD=0
  17925.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17926.     IF(IVLD.EQ.3)GOTO 9990
  17927.     DO 4650 N1=IXRL,IXRH
  17928.     DO 4650 N2=IXCL,IXCH
  17929. C FIND INDEX FOR WRKFIL
  17930.     CALL REFLEC(N2,N1,IRX)
  17931. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  17932.     CALL XVBLGT(N1,N2,TMP)
  17933. C TMP IS REAL*8 SCRATCH
  17934.     CALL FVLDST(N1,N2,Char(255))
  17935.     CALL WRKFIL(IRX,LBUF,0)
  17936. C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
  17937. C NOW GRAB THE VALUE AND SAVE IT...
  17938. C FIRST MOVE THE FORMAT DOWN
  17939. C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
  17940.     DO 4651 N=1,9
  17941.     LBUF(N+1)=LBUF(N+119)
  17942. 4651    CONTINUE
  17943.     LBUF(1)='('
  17944.     LBUF(11)=')'
  17945. c    LBUF(12)=0
  17946. C FORMAT NOW LIVES IN LOW PART OF LBUF
  17947. C D25.17 FORMAT WOULD DO FOR WRITE
  17948. C NEED CHAR VBL FOR FORMAT EQUIV'D TO LOW 12 CHARS OF LBUF
  17949. c    IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF(1:11),ERR=4652)TMP
  17950.     IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF,ERR=4652)TMP
  17951.     IF(IVLFG.EQ.2)WRITE(LINEC(1:62),4658,ERR=4652)TMP
  17952. 4658    FORMAT(D25.17)
  17953. C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
  17954. C USE DISPLAY FORMAT.
  17955. 4652    CONTINUE
  17956.     KK=1
  17957.     DO 4653 N=1,110
  17958. 4653    LBUF(N)=CHAR(0)
  17959.     DO 4654 N=1,60
  17960. C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
  17961.     KKK=JCHAR(LINECL(N))
  17962.     IF(KKK.LE.32)GOTO 4654
  17963.     LBUF(KK)=LINECL(N)
  17964.     KK=KK+1
  17965. 4654    CONTINUE
  17966.     CALL WRKFIL(IRX,LBUF,1)
  17967. 4650    CONTINUE
  17968.     MFIFLG=0
  17969.     MFOFLG=0
  17970.     GOTO 9999
  17971. 4700    CONTINUE
  17972.     CALL SCMP(LINE,'CMPFRM',6,ICODE)
  17973.     IF(ICODE.NE.1)GOTO 4800
  17974. C DBCMPFRM V1:V2
  17975. C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
  17976.     IBGN=7
  17977.     IVLD=0
  17978.     LSTCH=78
  17979. C USE GMTX TO GET CELL ADDRESSES.
  17980.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17981.     IF(IVLD.EQ.3)GOTO 9990
  17982. C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
  17983.     CALL REFLEC(IXCL,IXRL,IRXL)
  17984.     CALL REFLEC(IXCH,IXRH,IRXH)
  17985.     IF(LINE(LSTCH).NE.',')GOTO 4780
  17986.     IBGN=LSTCH+1
  17987.     IVLD=0
  17988.     CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
  17989.     IF(IVLD.EQ.3)GOTO 4780
  17990. C GET THE LENGTHS NOW
  17991.     CALL XVBLGT(IYRL,IYCL,TMP)
  17992.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  17993.     LBUFL=TMP
  17994.     CALL XVBLGT(IYRH,IYCH,TMP)
  17995.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  17996.     MBUFL=TMP
  17997. C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
  17998. C COMPARISONS BASED ON THAT.
  17999.     GOTO 4770
  18000. 4780    CONTINUE
  18001. C GET INDEX OF EACH ELEMENT...
  18002.     CALL WRKFIL(IRXL,LBUF,0)
  18003.     CALL WRKFIL(IRXH,MBUF,0)
  18004. C LOAD THE 2 FORMULAS.
  18005. C NOW FIND THE ENDS...
  18006.     DO 4750 N=1,110
  18007.     NN=111-N
  18008.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
  18009. 4750    CONTINUE
  18010. 4751    LBUFL=NN
  18011.     DO 4760 N=1,110
  18012.     NN=111-N
  18013.     IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
  18014. 4760    CONTINUE
  18015. 4761    MBUFL=NN
  18016. 4770    CONTINUE
  18017. c find index pos'n by hand...
  18018.     KK=LBUFL-MBUFL+1
  18019.     DO 4776 NN=1,KK
  18020.     IF(LBUF(NN).NE.MBUF(1))GOTO 4776
  18021.     NNN=MBUFL-1
  18022.     DO 4777 N=1,NNN
  18023.     IVVV=NN+N
  18024.     IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
  18025. 4777    CONTINUE
  18026. C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
  18027. C SINCE NN IS WHAT WE NEED, GO USE IT.
  18028.     GOTO 4779
  18029. 4778    CONTINUE
  18030. 4776    CONTINUE
  18031. C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
  18032. C
  18033.     NN=0
  18034. 4779    CONTINUE
  18035. C NN IS LOCATION OF SUBSTRING NOW
  18036. C    NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
  18037.     XAC=NN
  18038. C RETURN RESULT IN % ACCUMULATOR.
  18039.     WAC=0.
  18040.     IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
  18041.     IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
  18042. C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
  18043. C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
  18044. C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
  18045.     GOTO 9999
  18046. 4800    CONTINUE
  18047.     CALL SCMP(LINE,'LENFRM',6,ICODE)
  18048.     IF(ICODE.NE.1)GOTO 4900
  18049. C DBLENFRM V1:V2
  18050. C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
  18051.     IBGN=7
  18052.     IVLD=0
  18053. C USE GMTX TO GET CELL ADDRESSES.
  18054.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  18055.     IF(IVLD.EQ.3)GOTO 9990
  18056.     CALL REFLEC(IXCL,IXRL,IRXL)
  18057. C GET INDEX OF EACH ELEMENT...
  18058.     CALL WRKFIL(IRXL,LBUF,0)
  18059. C LOAD THE FORMULA.
  18060. C NOW FIND THE END...
  18061.     DO 4850 N=1,110
  18062.     NN=111-N
  18063.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
  18064. 4850    CONTINUE
  18065. 4851    LBUFL=NN
  18066.     TMP=LBUFL
  18067.     XAC=TMP
  18068. C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
  18069.     NN=0
  18070. C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
  18071.     CALL FVLDGT(IXRH,IXCH,NN)
  18072.     IF(NN.EQ.0)GOTO 9999
  18073.     CALL XVBLST(IXRH,IXCH,TMP)
  18074.     GOTO 9999
  18075. 4900    CONTINUE
  18076.     CALL SCMP(LINE,'TRMFRM',6,ICODE)
  18077.     IF(ICODE.NE.1)GOTO 5000
  18078. C TRIM FORMULA
  18079. C DTRTRMFRM INCELL:OUTCELL,START:END
  18080. C RETURNS TRIMMED FORMULA TO CELL.
  18081.     IBGN=7
  18082.     IVLD=0
  18083. C USE GMTX TO GET CELL ADDRESSES.
  18084.     CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
  18085.     IF(IVLD.EQ.3)GOTO 9990
  18086. C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
  18087.     CALL REFLEC(IXCL,IXRL,IRXL)
  18088. C GET INDEX OF EACH ELEMENT...
  18089.     CALL REFLEC(IXCH,IXRH,IRXH)
  18090.     CALL WRKFIL(IRXL,LBUF,0)
  18091.     LO=LSTCHR+1
  18092.     LHI=LSTCHR+21
  18093.     LSTCHR=LHI
  18094.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  18095.     IF(IVLD.EQ.0)GOTO 9990
  18096.     CALL XVBLGT(JD1,JD2,TMP)
  18097.     LOCHR=1
  18098.     IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
  18099. C LOCHR = START CHAR
  18100.     LO=LSTCHR+1
  18101.     LHI=LSTCHR+21
  18102.     LSTCHR=LHI
  18103.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  18104.     IF(IVLD.EQ.0)GOTO 9990
  18105.     CALL XVBLGT(JD1,JD2,TMP)
  18106.     LHICHR=110
  18107.     IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
  18108. C LHICHR IS END CHARACTER
  18109. C NOW ALL ARGS ARE COLLECTED.
  18110. C (IGNORE WHAT WAS DELIMITER...)
  18111. C COPY DESIRED STUFF TO MBUF
  18112.     N=1
  18113.     DO 4910 NN=1,110
  18114.     MBUF(NN)=CHAR(0)
  18115.     IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
  18116.     MBUF(N)=LBUF(NN)
  18117.     N=N+1
  18118. C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
  18119. 4910    CONTINUE
  18120.     DO 4911 NN=111,128
  18121. 4911    MBUF(NN)=LBUF(NN)
  18122.     CALL WRKFIL(IRXH,MBUF,1)
  18123. C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
  18124. C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
  18125.     GOTO 9999
  18126. 5000    CONTINUE
  18127.     GOTO 9999
  18128. 9990    RETCD=3
  18129. C ERROR RETURN
  18130. 9999    RETURN
  18131.     END
  18132. c -h- fft.ftn    Fri Aug 22 13:08:56 1986    
  18133. C  
  18134. C-----------------------------------------------------------------------
  18135. C SUBROUTINE: FOUREA
  18136. C PERFORMS COOLEY-TUKEY FAST FOURIER TRANSFORM
  18137. C-----------------------------------------------------------------------
  18138. C  
  18139.       SUBROUTINE FOUREA(ID1,ID2,IC,IR,IVN,ISI)
  18140. C ID1,ID2 = COORDS OF FIRST CELL. IC AND IR ARE 0, OR 1
  18141. C ONLY ONE OF IC, IR MAY BE NONZERO. (FLAGS HORIZ/VERTICAL
  18142. C DATA AREA)
  18143. C  
  18144. C THE COOLEY-TUKEY FAST FOURIER TRANSFORM IN ANSI FORTRAN
  18145. C  
  18146. C DATA IS A ONE-DIMENSIONAL COMPLEX ARRAY WHOSE LENGTH, N, IS A
  18147. C POWER OF TWO.  ISI IS +1 FOR AN INVERSE TRANSFORM AND -1 FOR A
  18148. C FORWARD TRANSFORM.  TRANSFORM VALUES ARE RETURNED IN THE INPUT
  18149. C ARRAY, REPLACING THE INPUT.
  18150. C TRANSFORM(J)=SUM(DATA(I)*W**((I-1)*(J-1))), WHERE I AND J RUN
  18151. C FROM 1 TO N AND W = EXP (ISI*2*PI*SQRT(-1)/N).  PROGRAM ALSO
  18152. C COMPUTES INVERSE TRANSFORM, FOR WHICH THE DEFINING EXPRESSION
  18153. C IS INVTR(J)=(1/N)*SUM(DATA(I)*W**((I-1)*(J-1))).
  18154. C RUNNING TIME IS PROPORTIONAL TO N*LOG2(N), RATHER THAN TO THE
  18155. C CLASSICAL N**2.
  18156. C AFTER PROGRAM BY BRENNER, JUNE 1967. THIS IS A VERY SHORT VERSION
  18157. C OF THE FFT AND IS INTENDED MAINLY FOR DEMONSTRATION. PROGRAMS
  18158. C ARE AVAILABLE IN THIS COLLECTION WHICH RUN FASTER AND ARE NOT
  18159. C RESTRICTED TO POWERS OF 2 OR TO ONE-DIMENSIONAL ARRAYS.
  18160. C SEE -- IEEE TRANS AUDIO (JUNE 1967), SPECIAL ISSUE ON FFT.
  18161. C  
  18162. C ASSUMES THAT FIRST N/2 ELEMENTS ARE REAL, SECOND COMPLEX...
  18163. C STORES DATA THAT WAY ALSO...
  18164. C
  18165. C      COMPLEX DATA(1)
  18166. C      COMPLEX TEMP, W
  18167. C MAKE THIS A REAL FFT, NOT COMPLEX...
  18168.     REAL*8 DATA(1),TEMP,W,TEMP2,TEMPI,WI
  18169.     InTeGer*4 ID1,ID2,IC,IR,IRX,IRXX,IVN,N
  18170. C SET UP STMT FUNCTIONS...
  18171.     ID1F(K)=ID1+IC*(K-1)
  18172.     ID2F(K)=ID2+IR*(K-1)
  18173.     N=IVN
  18174. C  
  18175. C CHECK FOR POWER OF TWO UP TO 14
  18176. C  
  18177. C INITIALLY SAY ALL OK
  18178.       NN = 1
  18179.       DO 10 I=1,14
  18180.         M = I
  18181.         NN = NN*2
  18182.         IF (NN.EQ.N) GO TO 20
  18183.     IF(NN.GT.N)GOTO 11
  18184.   10  CONTINUE
  18185. 11    CONTINUE
  18186.     N=NN/2
  18187. C USE NEXT SMALLER POWER OF 2 ARRAY...
  18188. C    RETURN
  18189. C HERE BEGINNETH ACTUAL WORK.
  18190. C SET UP DATA COORDS ON THE FLY. NORMALLY I,J RUN IN RANGE 1 TO N
  18191. C SO WHERE K=(I OR J) (I.E., ONE OF THE TWO) WE USE A RELATION
  18192. C ID1V=ID1+IC*(K-1) AND ID2V=ID2+IR*(K-1). WE USE STMT FUNCTIONS
  18193. C ID1F AND ID2F FOR THIS.
  18194.   20  CONTINUE
  18195.     NOV2=N/2
  18196. C  
  18197. C      PI = 4.*ATAN(1.)
  18198.     PI=3.14159265358979323846264
  18199.       FN = NOV2
  18200. C  
  18201. C THIS SECTION PUTS DATA IN BIT-REVERSED ORDER
  18202. C  
  18203.       J = 1
  18204.       DO 80 I=1,NOV2
  18205. C  
  18206. C AT THIS POINT, I AND J ARE A BIT REVERSED PAIR (EXCEPT FOR THE
  18207. C DISPLACEMENT OF +1)
  18208. C  
  18209.     IF(I.GE.J)GOTO 40
  18210. C  
  18211. C EXCHANGE DATA(I) WITH DATA(J) IF I.LT.J.
  18212. C  
  18213.  30    CONTINUE
  18214. C EXCHANGE DATA(J), DATA(I)
  18215.     CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
  18216.     CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
  18217.     CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
  18218.     CALL XVBLST(ID1F(I),ID2F(I),TEMP)
  18219. C FLIP BOTH REAL AND COMPLEX PARTS OF DATA
  18220.     CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMP)
  18221.     CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
  18222.     CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
  18223.     CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP)
  18224. C  30    TEMP = DATA(J)
  18225. C        DATA(J) = DATA(I)
  18226. C        DATA(I) = TEMP
  18227. C  
  18228. C IMPLEMENT J=J+1, BIT-REVERSED COUNTER
  18229. C  
  18230.   40    M = NOV2/2
  18231.   50    IF (J.LE.M) GOTO 70
  18232.   60    J = J - M
  18233.         M = (M+1)/2
  18234.         GO TO 50
  18235.   70    J = J + M
  18236.   80  CONTINUE
  18237. C  
  18238. C NOW COMPUTE THE BUTTERFLIES
  18239. C  
  18240.       MMAX = 1
  18241.   90  IF (MMAX.GE.NOV2)GOTO 130
  18242.  100  ISTEP = 2*MMAX
  18243.       DO 120 M=1,MMAX
  18244.         THETA = PI*FLOAT(ISI*(M-1))/FLOAT(MMAX)
  18245.      W = COS(THETA)
  18246.         WI = SIN(THETA)
  18247. C        W = CMPLX(COS(THETA),SIN(THETA))
  18248.         DO 110 I=M,NOV2,ISTEP
  18249.           J = I + MMAX
  18250. C GET REAL AND IMAG HALVES OF NUMBER...
  18251.       CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
  18252.       CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMPI)
  18253. C DO COMPLEX MULTIPLICATION BY HAND TO AVOID LARGE RUNTIME SYSTEM
  18254. C ROUTINE INCLUSION.
  18255.       TEMP2=W*TEMP-WI*TEMPI
  18256.       TEMPI=WI*TEMP+W*TEMPI
  18257.     TEMP=TEMP2
  18258. C          TEMP = W*DATA(J)
  18259. C          DATA(J) = DATA(I) - TEMP
  18260. C          DATA(I) = DATA(I) + TEMP
  18261.        CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
  18262.        TEMP2=DATA(1)+TEMP
  18263.        DATA(1)=DATA(1) - TEMP
  18264.        CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
  18265.        CALL XVBLST(ID1F(I),ID2F(I),TEMP2)
  18266. C COMPLEX PART
  18267.        CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
  18268.        TEMP2=DATA(1)+TEMPI
  18269.        DATA(1)=DATA(1) - TEMPI
  18270.        CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
  18271.        CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP2)
  18272.  110    CONTINUE
  18273.  120  CONTINUE
  18274.       MMAX = ISTEP
  18275.       GO TO 90
  18276.   130  IF (ISI.LT.0) GOTO 160
  18277. C  
  18278. C FOR INV TRANS -- ISI=1 -- MULTIPLY OUTPUT BY 1/N
  18279. C  
  18280.  140  DO 150 I=1,N
  18281. C        DATA(I) = DATA(I)/FN
  18282.     CALL XVBLGT(ID1F(I),ID2F(I),TEMP)
  18283.     TEMP=TEMP/FN
  18284.     CALL XVBLST(ID1F(I),ID2F(I),TEMP)
  18285.  150  CONTINUE
  18286.  160  RETURN
  18287.       END
  18288. c -h- help.for    Fri Aug 22 13:20:10 1986    
  18289.     SUBROUTINE HELP(LVL)
  18290. C PRINT HELP INFO ON SCREEN USING FIRST 22 LINES. ASSUME XQTCMD INVALIDATES
  18291. C THE DISPLAY.
  18292. C COPYRIGHT (C) 1983 GLENN AND MARY EVERHART
  18293.     CHARACTER*1 FORM(128)
  18294.     CALL UVT100(18,0,0)
  18295.     CALL UVT100(11,2,0)
  18296.     CALL UVT100(1,1,1)
  18297. C COPYRIGHT (C) 1983 GLENN and MARY EVERHART
  18298. C All Rights Reserved
  18299. C
  18300. C NEW PC HELP FILE
  18301. C DESIGNED TO BE SMALLER THAN OLD VERSION. READS FILES OFF DISK
  18302. C BY SKIPPING N*24 LINES AND DISPLAYING 24 LINES, WHERE N=LVL
  18303. C ASSUME HELP FILE ON DISK LOGGED CURRENTLY
  18304.     CLOSE(3)
  18305. c for now, assume help file lives on same disk as our default.
  18306.     IXXX=0
  18307.     OPEN(3,FILE='PCCHELP.HLP',STATUS='OLD',ACCESS='DIRECT',
  18308.      1  FORM='UNFORMATTED',RECL=128,IOSTAT=IXXX)
  18309. C try on dk: if we can't find it in default.
  18310.     If(IXXX.LE.0)goto 2772
  18311.     Close(3)
  18312.     OPEN(3,FILE='DK:PCCHELP.HLP',STATUS='OLD',ACCESS='DIRECT',
  18313.      1  FORM='UNFORMATTED',RECL=128,IOSTAT=IXXX)
  18314.     IF(IXXX.GT.0)RETURN
  18315. 2772    Continue
  18316. C RETURN IF HELP FILE IS MISSING...
  18317. C USE A FIXED HELP FILE FOR MULTISCREEN HELP. LOWER OVERHEAD,...
  18318.     NSKP=LVL*24
  18319. C NOW READ IN THE DATA, WRITE TO SCREEN.
  18320.     KKL=NSKP+1
  18321.     KKH=NSKP+23
  18322. C JUST GO DIRECTLY TO THE DESIRED SCREENFUL OF INFO.
  18323.     DO 7640 KKK=KKL,KKH
  18324.     READ(3,REC=KKK,END=7642,ERR=7642)FORM
  18325. c use fortran writes here normally since we want the crlf stuff they imply
  18326. c always write 24 lines to scroll all else off...
  18327.     IVVV=78
  18328. C FIND END OF LINE AND ONLY EMIT CHARACTERS TO THAT; DON'T WASTE
  18329. C TIME DRAWING SPACES ON THE SCREEN.
  18330.     DO 772 IV=1,78
  18331.     IVVV=79-IV
  18332.     IF(ICHAR(FORM(IVVV)).GT.32)GOTO 773
  18333. 772    CONTINUE
  18334. 773    CONTINUE
  18335.     FORM(IVVV+1)=Char(13)
  18336.     FORM(IVVV+2)=Char(10)
  18337.     IVVV=IVVV+2
  18338.     CALL SWRT(FORM,IVVV)
  18339. C    WRITE(11,7643)(FORM(IV),IV=1,IVVV)
  18340. C NOTE WE HAVE LUN 6 OPENED AS CON: IN THE MAIN PROGRAM TO GIVE AN
  18341. C INDEPENDENT TERMINAL OUTPUT CHANNEL. HOPEFULLY THIS PREVENTS SOME
  18342. C SCREWUPS DUE TO USING LUN 0 FOR BOTH CONSOLE INPUT AND OUTPUT; END OF
  18343. C RECORDS OUGHT TO BE INDEPENDENT THIS WAY (I HOPE).
  18344. C7643    FORMAT(1X,82A1,4A1)
  18345. 7640    CONTINUE
  18346. 7642    CONTINUE
  18347.     CLOSE(3)
  18348.     FORM(1)=13
  18349.     CALL SWRT(FORM,1)
  18350.     RETURN
  18351.     END
  18352. c -h- linfit.for    Fri Aug 22 13:23:55 1986    
  18353. C LINE FITTING SUBROUTINE WITH ERROR MEASURE RETURN ALSO.
  18354.     SUBROUTINE LINFIT(ID1X,ID2X,IRCOL,ID1,ID2,N,A,B,DEL,RR)
  18355.     InTeGer*4 ID1X,ID2X,IRCOL,ID1,ID2,N
  18356.     REAL*8 A,B,DEL,XY,SX2,SX,SY,RR
  18357.     InTeGer*4 IC,IR,KK,KKK,I
  18358.     REAL*8 XI,YI,SY2,EN,WRK
  18359. C FIT LINE TO EQUALLY SPACED POINTS...
  18360. C Y=BX+A
  18361.     SY2=0.
  18362.     EN=N
  18363.     XY=0.
  18364.     SX2=0.
  18365.     SX=0.
  18366.     SY=0.
  18367.     IC=IRCOL
  18368.     IR=1-IRCOL
  18369. C IRCOL IS 0 OR 1 FOR ACROSS OR DOWN
  18370.     DO 10 I=1,N
  18371. C IF ID1X < 0 THEN FORM IT HERE AS ID1+I-1
  18372.     IF (ID1X.GT.0)GOTO 20
  18373. C FORM XI
  18374.     XI=I
  18375.     GOTO 30
  18376. 20    CONTINUE
  18377. C INPUT XI
  18378.     KK=ID1X+IC*(I-1)
  18379.     KKK=ID2X+IR*(I-1)
  18380.     CALL XVBLGT(KK,KKK,XI)
  18381. 30    CONTINUE
  18382. C GET YI IN ANY CASE...
  18383.     KK=ID1+IC*(I-1)
  18384.     KKK=ID2+IR*(I-1)
  18385.     CALL XVBLGT(KK,KKK,YI)
  18386.     XY=XY+XI*YI
  18387. C FORM SUMS NEEDED TO FIT LINE...
  18388.     SX2=SX2+XI*XI
  18389.     SX=SX+XI
  18390.     SY=SY+YI
  18391.     SY2=SY2+YI*YI
  18392. 10    CONTINUE
  18393. C NOW GET SLOPE
  18394.     WRK=((XY-(SX*SY)/EN)/(SX2-(SX*SX)/EN))
  18395.     B=WRK
  18396. C THEN INTERCEPT
  18397.     WRK=(SY/EN)-B*(SX/EN)
  18398.     A=WRK
  18399.     WRK=DSQRT((SY2-(A*SY+B*XY))/EN)
  18400.     DEL=WRK
  18401. C DEL = ERROR OF FIT
  18402.     RR=(EN*XY-SX*SY)/DSQRT((EN*SX2-SX*SX)*(EN*SY2-SY*SY))
  18403. C RR IS CORRELATION COEFFICIENT
  18404.     RETURN
  18405.     END
  18406. c -h- list.for    Fri Aug 22 13:24:14 1986    
  18407.     SUBROUTINE LIST
  18408. C COPYRIGHT (C) 1983 GLENN EVERHART
  18409. C ALL RIGHTS RESERVED
  18410. C 60=MAX REAL ROWS
  18411. C 301=MAX REAL COLS
  18412. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  18413. C VBLS AND TYPE DIMENSIONED 60,301
  18414. C **************************************************
  18415. C *                                                *
  18416. C *              SUBROUTINE  LIST                  *
  18417. C *                                                *
  18418. C **************************************************
  18419. C
  18420. C
  18421. C LISTS THE LEGAL CALC COMMANDS AND GIVES A BRIEF
  18422. C DESCRIPTION OF THEIR FUNCTION.
  18423. C
  18424. C LIST IS CALLED BY CALC
  18425. C
  18426. C    SUBROUTINE LIST
  18427. C
  18428. C
  18429. C NOTE WE USE FORTRAN WRITE HERE SINCE IT SHOULD ONLY HAPPEN IN CALC MODE.
  18430. c    rewind 11
  18431. c    WRITE (11,20)
  18432. c    WRITE (11,30)
  18433. c    rewind 11
  18434.     Call vwrt(char(13)//char(10),2)
  18435.     Call vwrt(
  18436.      1  'Cmds= @file-do file;*C-Comment;*E-exit;*R-Read con',50)
  18437.     Call vwrt(char(13)//char(10),2)
  18438.     Call Vwrt(
  18439.      1  '*S-stop;*V n(bet.0,3)-View Ctl - Higher=see more',48)
  18440.     RETURN
  18441. c20    FORMAT (' CMDS= @FILE-DO FILE;*C-COMMENT;*E-EXIT;*R-READ CON')
  18442. c30    FORMAT (' *S-STOP;*V n(bet.0,3)-VIEW CTL- HIGHER=SEE MORE')
  18443.     END
  18444. c -h- wsset.f40    Fri Aug 22 13:43:11 1986    
  18445.         SUBROUTINE WSSET
  18446. C WORK SHEET MANAGMENT ROUTINES
  18447. C HANDLE SPREADSHEET "IN MEMORY" STORAGE
  18448. C COPYRIGHT (C) GLENN AND MARY EVERHART 1983,1984
  18449. C
  18450. C ALL RIGHTS RESERVED
  18451. C
  18452. C WSSET - INITIALIZE STORAGE TO START CONDITIONS
  18453. C EXPECT IMPLEMENTATION TO USE A COMMON BITMAP AND PROVIDE A VARIABLE
  18454. C NCEL TO TELL HOW MANY CELLS ARE IN USE
  18455. C NEXT BITMAPS IMPLEMENT FVLD
  18456.     Include AParms.Inc
  18457.         CHARACTER*1 FV1(IMP1S),FV2(IMP1S),FV4(IMP1S)
  18458.     CHARACTER*1 FVXX(IMPS3)
  18459.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(IMP2S))
  18460.     EQUIVALENCE (FV4(1),FVXX(IMP3S))
  18461.         Common/FVLDM/FVXX
  18462. c        COMMON/FVLDM/FV1,FV2,FV4
  18463. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  18464. C TYPES OF AC'S STORAGE:
  18465.         CHARACTER*1 ITYP(IMP1S)
  18466.         InTeGer*4 IATYP(27),LINTGR
  18467.         COMMON/TYP/IATYP,ITYP,LINTGR
  18468.         CHARACTER*1 LBITS(8)
  18469.         COMMON/BITS/LBITS
  18470. C ***<<<< RDD COMMON START >>>***
  18471.     InTeGer*4 RRWACT,RCLACT
  18472. C    COMMON/RCLACT/RRWACT,RCLACT
  18473.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  18474.      1  IDOL7,IDOL8
  18475. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  18476. C     1  IDOL7,IDOL8
  18477.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  18478. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  18479.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  18480. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  18481. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  18482. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  18483.     InTeGer*4 KLVL
  18484. C    COMMON/KLVL/KLVL
  18485.     InTeGer*4 IOLVL,IGOLD
  18486. C    COMMON/IOLVL/IOLVL
  18487. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  18488. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  18489.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  18490.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  18491.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  18492.      3  k3dfg,kcdelt,krdelt,kpag
  18493. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  18494. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  18495. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  18496. C ***<<< RDD COMMON END >>>***
  18497. CCC        InTeGer*4 IPGMAX,LPGMXF
  18498. CCC        COMMON/FILEMX/IPGMAX,LPGMXF
  18499. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  18500. C USE LUN 7 FOR FORMULAS, 9 FOR VALUES FILE IF NEEDED...
  18501. C
  18502. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  18503. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  18504. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  18505. C AREAS WITH DATA.
  18506. C ***<<< KLSTO COMMON START >>>***
  18507.     InTeGer*4 DLFG
  18508. C    COMMON/DLFG/DLFG
  18509.     InTeGer*4 KDRW,KDCL
  18510. C    COMMON/DOT/KDRW,KDCL
  18511.     InTeGer*4 DTRENA
  18512. C    COMMON/DTRCMN/DTRENA
  18513.     REAL*8 EP,PV,FV
  18514.     DIMENSION EP(20)
  18515.     INTEGER*4 KIRR
  18516. C    COMMON/ERNPER/EP,PV,FV,KIRR
  18517.     InTeGer*4 LASTOP
  18518. C    COMMON/ERROR/LASTOP
  18519.     CHARACTER*1 FMTDAT(9,76)
  18520. C    COMMON/FMTBFR/FMTDAT
  18521.     CHARACTER*1 EDNAM(16)
  18522. C    COMMON/EDNAM/EDNAM
  18523.     InTeGer*4 MFID(2),MFMOD(2)
  18524. C    COMMON/FRM/MFID,MFMOD
  18525.     InTeGer*4 JMVFG,JMVOLD
  18526. C    COMMON/FUBAR/JMVFG,JMVOLD
  18527.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  18528.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  18529. C ***<<< KLSTO COMMON END >>>***
  18530. CCC        CHARACTER*1 FMTDAT(9,76)
  18531. CCC        COMMON/FMTBFR/FMTDAT
  18532.         CHARACTER*1 DVF(12),DFMT(10)
  18533.         EQUIVALENCE(DVF(2),DFMT(1))
  18534.         COMMON/DEFVBX/DVF
  18535. CCC    InTeGer*4 DLFG
  18536. CCC    COMMON/DLFG/DLFG
  18537. C DLFG IS NONZERO IF ANY D## FORMS HAVE BEEN SEEN
  18538.         InTeGer*4 MPAG(2),MPMOD
  18539.         InTeGer*2 LVALBF(5,MVal)
  18540.     DIMENSION MPMOD(2)
  18541.         COMMON/VB/MPAG,LVALBF,MPMOD
  18542.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  18543.     COMMON/VBCTL/MFLAST,MFBASE,MVLASE,MVBASE
  18544. CCC    InTeGer*4 MFID(2)
  18545. C        InTeGer*4 MFID,IFID(8,MFrm)
  18546. C        CHARACTER*1 LFID(16,MFrm)
  18547. C        EQUIVALENCE(IFID(1,1),LFID(1,1))
  18548. CCC        COMMON/FRM/MFID,MFMOD
  18549. C        COMMON/FRM/MFID,IFID
  18550. C
  18551. C ***<<< NULETC COMMON START >>>***
  18552.     InTeGer*4 ICREF,IRREF
  18553. C    COMMON/MIRROR/ICREF,IRREF
  18554.     InTeGer*4 MODPUB,LIMODE
  18555. C    COMMON/MODPUB/MODPUB,LIMODE
  18556.     InTeGer*4 KLKC,KLKR
  18557.     REAL*8 AACP,AACQ
  18558. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  18559.     InTeGer*4 NCEL,NXINI
  18560. C    COMMON/NCEL/NCEL,NXINI
  18561.     CHARACTER*1 NAMARY(20,MRows)
  18562. C    COMMON/NMNMNM/NAMARY
  18563.     InTeGer*4 NULAST,LFVD
  18564. C    COMMON/NULXXX/NULAST,LFVD
  18565.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  18566.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  18567. C ***<<< NULETC COMMON END >>>***
  18568. CCC        COMMON /NCEL/NCEL,NXINI
  18569.     LINTGR=0
  18570.     MPMOD(1)=0
  18571.     MPMOD(2)=0
  18572.     MFMOD(1)=0
  18573.     MFMOD(2)=0
  18574.     DLFG=0
  18575.         IBP=1
  18576. C INITIALIZE ADDRESSES FOR FVLDSG/FVLDGT
  18577. C    CALL FVGO(FV1,LBITS)
  18578.         DO 2 N=1,9
  18579. 2       FMTDAT(N,1)=DFMT(N)
  18580.         DO 3 N=2,76
  18581.         DO 3 NN=1,9
  18582. 3       FMTDAT(NN,N)=CHAR(0)
  18583.         DO 1 N=1,8
  18584.     NN=128/IBP
  18585.         LBITS(N)=CHAR(NN)
  18586. 1       IBP=IBP+IBP
  18587.         DO 4 N=1,IMP1S
  18588. C CLEAR BITMAPS NOW
  18589.         FV1(N)=CHAR(0)
  18590.         FV2(N)=CHAR(0)
  18591.         FV4(N)=CHAR(0)
  18592. 4       ITYP(N)=CHAR(0)
  18593. C OPEN THE WORK FILES SO WE DON'T NEED TO LATER...
  18594. C LUN 7 IS FORMULAS; LUN 9 IS VALUES
  18595. C HOWEVER, IF IPGMAX IS LESS THAN 800/205 (INDICATING ENTIRE FILE
  18596. C FITS IN MEMORY) DON'T OPEN LUN 9 AND IF LPGMXF IS < 2048/64, LIKEWISE
  18597. C FOR LUN 7.
  18598. C INITIALLY CLOSE FILES IN CASE THEY WERE OPEN...
  18599.         CLOSE(7,STATUS='DELETE')
  18600.         CLOSE(13,STATUS='DELETE')
  18601. C NOW OPEN THEM AS RANDOM ACCESS FILES.
  18602.         NBK=IPGMAX*2
  18603. C KEEP VALUE PAGES IN 500 BYTE UNITS, NOT 512 BYTE UNITS, TO COME
  18604. C OUT EVEN...
  18605.         IF(IPGMAX.GT.(MVal/100))OPEN(13,
  18606.      1  ACCESS='DIRECT',FORM='UNFORMATTED',
  18607.      3  RECL=500,STATUS='NEW')
  18608.         NBK=LPGMXF*2
  18609.         IF(LPGMXF.GT.(MFro64))OPEN(7,
  18610.      1  ACCESS='DIRECT',FORM='UNFORMATTED',
  18611.      3  RECL=512,STATUS='NEW')
  18612. C SET NOTHING IN MEMORY YET
  18613.         MFID(1)=0
  18614.     MFID(2)=0
  18615.         MPAG(1)=0
  18616.     MPAG(2)=0
  18617. C MARK BUFFER 1 AS IN MEMORY AND AS LAST-ACCESSED (SO WE FIRST ATTEMPT TO
  18618. C OVERWRITE BUFFER 2 TO GET STARTED.)
  18619.     MFLAST=1
  18620.     MFBASE=0
  18621.     MVLAST=1
  18622.     MVBASE=0
  18623. C ZERO MEMORY BUFFER AND FILES
  18624. C ACTUALLY MARK WITH -1 SO THAT WE CAN TELL WHEN WE HIT A VIRGIN
  18625. C AREA.
  18626.         DO 9 N=1,MVal
  18627.         DO 9 M=1,5
  18628.     KKKKK=-1
  18629. 9       LVALBF(M,N)=KKKKK
  18630.         NPG=(IPGMAX*2)
  18631.         IF(IPGMAX.LE.(MVal/100))GOTO 11
  18632.         DO 10 N=1,NPG
  18633. 10      WRITE(13,REC=N,ERR=11)((LVALBF(K,KKK),K=1,5),KKK=1,50)
  18634. 11      CONTINUE
  18635.     CALL WRKFIL(0,0,50)
  18636. C        DO 12 N=1,2048
  18637. C        DO 12 M=1,8
  18638. C12      IFID(M,N)=0
  18639. C     NPG=LPGMXF*2
  18640. C        IF(LPGMXF.LE.(2048/64))GOTO 14
  18641. C        DO 13 N=1,NPG
  18642. C13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
  18643. 14      CONTINUE
  18644. C SET ALL AC'S TO TYPE FLOATING...
  18645.         DO 8 N=1,27
  18646. 8       IATYP(N)=2
  18647. C TYPE 2 IS REALS (DEFAULT)
  18648.         NCEL=0
  18649.     NXINI=0
  18650.         RETURN
  18651.         END
  18652. c -h- wtbini.f40    Fri Aug 22 13:43:29 1986    
  18653. C WORK FORMULA TABLE INITIALIZE FOR DTBL1 COMMON
  18654. C COPYRIGHT (C) GLENN AND MARY EVERHART 1985
  18655. C ALL RIGHTS RESERVED
  18656.     SUBROUTINE WTBINI(IFID,LPGMXF,BTBL1,BTBL2,BTBL3,BTBL4,BTBL5,
  18657.      1  BTBL6,BTBL7,BTBL8)
  18658.     Include Aparms.inc
  18659.     CHARACTER*1 DTBL1(9,9,8)
  18660. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  18661.     Integer*4 LPGMXF
  18662. C    InTeGer*2 BTBL(6,6,8)
  18663. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  18664. C NO NEED TO WASTE IT.
  18665.     InTeGer*2 IFID(8,MFrm)
  18666. C    CHARACTER*1 LFID(16,MFrm)
  18667. C    EQUIVALENCE(LFID(1,1),IFID(1,1))
  18668. C    EQUIVALENCE(IFID(1,1),BTBL(1,1,1))
  18669.     InTeGer*2 BTBL1(6,6)
  18670.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  18671.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  18672. C    EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  18673. C    EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  18674. C    EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  18675. C    EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  18676.     COMMON /DECIDE/ DTBL1
  18677. C ONLY INIT DTBL1 ENTRIES NOT CORRESPONDING TO MULTIPLE PRECISION DATA
  18678. C TYPES (WHICH ARE NOT SUPPORTED HERE)
  18679.     do 135 n3=1,8
  18680.     do 135 n2=1,9
  18681.     do 135 n1=1,9
  18682. 135    dtbl1(n1,n2,n3)=CHAR(0)
  18683.     DO 35 NN2=1,6
  18684.     N2=NN2
  18685.     IF(NN2.GT.4)N2=NN2+3
  18686.     DO 235 N1=1,4
  18687.     DTBL1(N1,N2,1)=CHAR(BTBL1(N1,NN2))
  18688.     DTBL1(N1,N2,2)=CHAR(BTBL2(N1,NN2))
  18689.     DTBL1(N1,N2,3)=CHAR(BTBL3(N1,NN2))
  18690.     DTBL1(N1,N2,4)=CHAR(BTBL4(N1,NN2))
  18691.     DTBL1(N1,N2,5)=CHAR(BTBL5(N1,NN2))
  18692.     DTBL1(N1,N2,6)=CHAR(BTBL6(N1,NN2))
  18693.     DTBL1(N1,N2,7)=CHAR(BTBL7(N1,NN2))
  18694. 235    DTBL1(N1,N2,8)=CHAR(BTBL8(N1,NN2))
  18695.     do 335 n1=5,6
  18696.     DTBL1(N1+3,N2,1)=CHAR(BTBL1(N1,NN2))
  18697.     DTBL1(N1+3,N2,2)=CHAR(BTBL2(N1,NN2))
  18698.     DTBL1(N1+3,N2,3)=CHAR(BTBL3(N1,NN2))
  18699.     DTBL1(N1+3,N2,4)=CHAR(BTBL4(N1,NN2))
  18700.     DTBL1(N1+3,N2,5)=CHAR(BTBL5(N1,NN2))
  18701.     DTBL1(N1+3,N2,6)=CHAR(BTBL6(N1,NN2))
  18702.     DTBL1(N1+3,N2,7)=CHAR(BTBL7(N1,NN2))
  18703.     DTBL1(N1+3,N2,8)=CHAR(BTBL8(N1,NN2))
  18704. 335    continue
  18705. 35    CONTINUE
  18706. C NOW CLEAR THE BUFFER OUT, HAVING SET UP DTBL1 FROM IT.
  18707. C SET INITIAL -1 SO WE CAN RECOGNIZE WHEN TO STOP LOOKING
  18708. C INITIALLY...
  18709.     DO 36 NN=1,MFrm
  18710.     DO 36 N=1,8
  18711.     KKKKK=-1
  18712. 36    IFID(N,NN)=KKKKK
  18713. C ZERO THE FILE NOW
  18714.     NPG=LPGMXF*2
  18715.         IF(LPGMXF.LE.(MFro64))GOTO 14
  18716.         DO 13 N=1,NPG
  18717. 13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
  18718. 14      CONTINUE
  18719.     RETURN
  18720.     END
  18721. c -h- wkdy.for    Fri Aug 22 13:44:33 1986    
  18722.     SUBROUTINE WKDY(JULLO,JULHI,NDAYS)
  18723. C GIVEN START AND END JULIAN DATE, FIGURE OUT HOW MANY WEEK DAYS
  18724. C THERE ARE BETWEEN THEM.
  18725.     JL=JULLO
  18726.     JH=JULHI
  18727.     IF(JL.LE.JH)GOTO 10
  18728.     JL=JULHI
  18729.     JH=JULLO
  18730. 10    CONTINUE
  18731.     IDL=(JH-JL)/7
  18732. C GET NUMBER OF WEEKS BETWEEN DAYS, 5 WORKDAYS PER WHOLE WEEK.
  18733.     IWDY=IDL*5
  18734. C ADD 3 SO THAT MODULO OF SUNDAY IS 0, NOT WED.
  18735.     IDOR=JH-JL-7*(IDL)
  18736.     IF(IDOR.NE.0)IDOR=5
  18737. C IDOR IS ORIGINAL # DAYS DIFFERENCE, CORRECTED FOR WHOLE
  18738. C WEEKS ALREADY ALLOWED.
  18739.     LD=JL+3
  18740.     LD=MOD(LD,7)
  18741.     LH=JH+3
  18742.     LH=MOD(LH,7)
  18743. C NOW HAVE DAY OF WEEK START,END. FIND WORK DAYS THAT WEEK (M-F ONLY)
  18744.     IKLU=0
  18745.     IK2=1
  18746.     IF(LD.LT.1)IK2=0
  18747.     IF(LD.LT.1)LD=1
  18748.     IF(LD.GT.5)LD=5
  18749. C FOR HIGH END OF RANGE IF THE END DATE IS SUNDAY SUBTRACT ONE DAY
  18750. C FROM THE DAYS SO WE OMIT THE MONDAY FROM THE RANGE...
  18751.     IF(LH.LT.1)IKLU=IK2
  18752.     IF(LH.LT.1)LH=1
  18753.     IF(LH.GT.5)LH=5
  18754. C LH = DAY ENDED ON, LD=START DAY, FORCED INTO WORK WEEK.
  18755.     IF (LH.GT.LD)IWDY=IWDY+LH-LD-IKLU
  18756.     IF (LH.LE.LD)IWDY=IWDY+IDOR-(LD-LH)-IKLU
  18757. C GIVES DAYS BETWEEN 2 DATES JUST LIKE JULIAN DATE SUBTRACTION FOR
  18758. C CALENDAR DATES.
  18759.     NDAYS=IWDY
  18760.     RETURN
  18761.     END
  18762. c -h- wrkint.for    Fri Aug 22 13:44:46 1986    
  18763.     SUBROUTINE WRKINT(JULLO,NWDY,JULHI)
  18764. C GETS JULLO = START DATE AND NWDY = NO. WORKDAYS (M-F) TO ADD AND
  18765. C FINDS JULHI = END JULIAN DATE, CONSTRAINED TO BE IN MONDAY TO
  18766. C FRIDAY RANGE.
  18767. C MUST ADD 3 BECAUSE THAT'S THE BIAS OF OUR JULIAN DATE BASE.
  18768.     IDJL=MOD(JULLO+3,7)
  18769. C IDJL = DAY CODE OF START DATE
  18770.     NWWK=NWDY/5
  18771.     JL=JULLO
  18772.     IF(IDJL.LT.1)JL=JL+1
  18773.     IF(IDJL.GT.5)JL=JL+2
  18774. C BUMP START INTERVAL...
  18775.     NWDD=NWDY-5*NWWK
  18776.     JL=JL+NWWK*7+NWDD
  18777.     IDJL=MOD(JL+3,7)
  18778.     IF(IDJL.LT.1)JL=JL+1
  18779.     IF(IDJL.GT.5)JL=JL+2
  18780. C FORCE OUTPUT DATE TO BE WITHIN WORKWEEK
  18781.     JULHI=JL
  18782.     RETURN
  18783.     END
  18784. C ****************** AnalyTZ.Ftn ########################################3
  18785. c -h- test.for    Fri Aug 22 13:35:58 1986    
  18786.     SUBROUTINE TEST(LOGTYP,FLAG,V1,V2)
  18787.     InTeGer*4 FLAG
  18788.     REAL*8 V1,V2
  18789.     FLAG=0
  18790.     IF(LOGTYP.EQ.1.AND.V1.GT.V2)FLAG=1
  18791.     IF(LOGTYP.EQ.2.AND.V1.LT.V2)FLAG=1
  18792.     IF(LOGTYP.EQ.3.AND.V1.EQ.V2)FLAG=1
  18793.     IF(LOGTYP.EQ.4.AND.V1.NE.V2)FLAG=1
  18794.     IF(LOGTYP.EQ.5.AND.V1.GE.V2)FLAG=1
  18795.     IF(LOGTYP.EQ.6.AND.V1.LE.V2)FLAG=1
  18796. C TEST LOGICAL RELATIONS FOR IF STATEMENT, FLAG=1 IF TRUE, 0 ELSE.
  18797.     RETURN
  18798.     END
  18799. c -h- ttydei.for    Fri Aug 22 13:35:58 1986    
  18800.     SUBROUTINE TTYDEI
  18801.     INCLUDE DOS.INC
  18802.     INTEGER *4 MODE
  18803.     Integer*4 Amiga
  18804.     External Amiga
  18805. C ***<<< XVXTCD COMMON START >>>***
  18806.     CHARACTER*1 OARRY(100)
  18807.     InTeGer*4 OSWIT,OCNTR
  18808. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  18809. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  18810.     InTeGer*4 IPS1,IPS2,MODFLG
  18811. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  18812.        InTeGer*4 XTCFG,IPSET,XTNCNT
  18813.        CHARACTER*1 XTNCMD(80)
  18814. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  18815. C VARY FLAG ITERATION COUNT
  18816.     INTEGER KALKIT
  18817. C    COMMON/VARYIT/KALKIT
  18818.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  18819.     InTeGer*4 RCMODE,IRCE1,IRCE2
  18820. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  18821. C     1  IRCE2
  18822. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  18823. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  18824. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  18825. C RCFGX ON.
  18826. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  18827. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  18828. C  AND VM INHIBITS. (SETS TO 1).
  18829.     INTEGER*4 FH
  18830. C FILE HANDLE FOR CONSOLE I/O (RAW)
  18831. C    COMMON/CONSFH/FH
  18832.     CHARACTER*1 ARGSTR(52,4)
  18833. C    COMMON/ARGSTR/ARGSTR
  18834.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  18835.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  18836.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  18837.      3  IRCE2,FH,ARGSTR
  18838. C ***<<< XVXTCD COMMON END >>>***
  18839. CCC    COMMON/CONSFH/FH
  18840.     If (FH.ne.0)Call Amiga(Close,FH)
  18841.     RETURN
  18842.     END
  18843. c -h- ttyini.for    Fri Aug 22 13:35:58 1986    
  18844.     SUBROUTINE TTYINI
  18845. C PERFORM INITS ON UNIT 5. NORMALLY EITHER DO NOTHING OR
  18846. C REPLACE WITH SOMETHING THAT WORKS FOR YOUR SYSTEM. TYPICAL
  18847. C ACTIONS:
  18848. C  SET THE TERMINAL NOT TO WRAP AROUND
  18849. C  ATTACH TERMINAL SO TYPE-AHEAD WORKS
  18850. C  SET UP TERMINAL TO MUNGE AROUND THE ESCAPE SEQUENCES TO ALLOW
  18851. C  SPECIAL FUNCTION AND/OR ARROW KEYS TO WORK.
  18852. C ULTIMATELY USE WRITE OF UNIT 0 TO DUMP OUT SOME USEFUL ESCAPE SEQS.
  18853. C TO DEFINE FUNCTION KEYS A LA VT100 (SORT OF).
  18854.     INCLUDE DOS.INC
  18855.     CHARACTER*40 NAME
  18856.     INTEGER *4 MODE
  18857.     Integer*4 Amiga
  18858.     External Amiga
  18859. C ***<<< XVXTCD COMMON START >>>***
  18860.     CHARACTER*1 OARRY(100)
  18861.     InTeGer*4 OSWIT,OCNTR
  18862. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  18863. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  18864.     InTeGer*4 IPS1,IPS2,MODFLG
  18865. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  18866.        InTeGer*4 XTCFG,IPSET,XTNCNT
  18867.        CHARACTER*1 XTNCMD(80)
  18868. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  18869. C VARY FLAG ITERATION COUNT
  18870.     INTEGER KALKIT
  18871. C    COMMON/VARYIT/KALKIT
  18872.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  18873.     InTeGer*4 RCMODE,IRCE1,IRCE2
  18874. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  18875. C     1  IRCE2
  18876. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  18877. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  18878. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  18879. C RCFGX ON.
  18880. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  18881. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  18882. C  AND VM INHIBITS. (SETS TO 1).
  18883.     INTEGER*4 FH
  18884. C FILE HANDLE FOR CONSOLE I/O (RAW)
  18885. C    COMMON/CONSFH/FH
  18886.     CHARACTER*1 ARGSTR(52,4)
  18887. C    COMMON/ARGSTR/ARGSTR
  18888.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  18889.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  18890.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  18891.      3  IRCE2,FH,ARGSTR
  18892. C ***<<< XVXTCD COMMON END >>>***
  18893. C ***<<<< RDD COMMON START >>>***
  18894.     InTeGer*4 RRWACT,RCLACT
  18895. C    COMMON/RCLACT/RRWACT,RCLACT
  18896.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  18897.      1  IDOL7,IDOL8
  18898. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  18899. C     1  IDOL7,IDOL8
  18900.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  18901. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  18902.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  18903. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  18904. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  18905. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  18906.     InTeGer*4 KLVL
  18907. C    COMMON/KLVL/KLVL
  18908.     InTeGer*4 IOLVL,IGOLD
  18909. C    COMMON/IOLVL/IOLVL
  18910. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  18911. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  18912.     Integer*4 IDSPTP,Idol9
  18913.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  18914.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  18915.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  18916.      3  k3dfg,kcdelt,krdelt,kpag
  18917. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  18918. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  18919. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9
  18920. C ***<<< RDD COMMON END >>>***
  18921. CCC    COMMON/CONSFH/FH
  18922. c Resize initial windows so all fit on NON interlace screen
  18923.     If(IDSPTP.NE.1)NAME=
  18924.      1  "RAW:0/0/639/199/AnalytiCalc-AMIGA" // CHAR(0)
  18925.     IF(IDSPTP.EQ.1)NAME=
  18926.      1  "RAW:0/0/639/399/AnalytiCalc-AMIGA" // CHAR(0)
  18927.     MODE=MODE_NEWFILE
  18928.     FH=AMIGA(Open,NAME,MODE)
  18929.     RETURN
  18930.     END
  18931. c -h- typget.for    Fri Aug 22 13:35:58 1986    
  18932.         SUBROUTINE TYPGET(ID1,ID2,IVAL)
  18933.     Include AParms.Inc
  18934. C
  18935. C TYPGET - GET TYPE(60,301) ARRAY WORDS BACK
  18936. C RETURN TYPE(ID1,ID2) IN IVAL, BUT NOT REALLY...
  18937. C NEXT BITMAPS IMPLEMENT FVLD
  18938.         CHARACTER*1 FV1(IMP1S),FV2(IMP1S),FV4(IMP1S)
  18939.     CHARACTER*1 FVXX(IMPs3)
  18940.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  18941.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  18942.         Common/FVLDM/FVXX
  18943. c        COMMON/FVLDM/FV1,FV2,FV4
  18944.         CHARACTER*1 LBITS(8)
  18945.         COMMON/BITS/LBITS
  18946. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  18947. C TYPES OF AC'S STORAGE:
  18948.     LOGICAL*4 LB1,LB2
  18949.     InTeGer*4 KB1,KB2
  18950.     EQUIVALENCE(LB1,KB1),(LB2,KB2)
  18951.         CHARACTER*1 ITYP(IMP1S)
  18952.         InTeGer*4 IATYP(27),LINTGR
  18953.         COMMON/TYP/IATYP,ITYP,LINTGR
  18954. C ***<<< NULETC COMMON START >>>***
  18955.     InTeGer*4 ICREF,IRREF
  18956. C    COMMON/MIRROR/ICREF,IRREF
  18957.     InTeGer*4 MODPUB,LIMODE
  18958. C    COMMON/MODPUB/MODPUB,LIMODE
  18959.     InTeGer*4 KLKC,KLKR
  18960.     REAL*8 AACP,AACQ
  18961. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  18962.     InTeGer*4 NCEL,NXINI
  18963. C    COMMON/NCEL/NCEL,NXINI
  18964.     CHARACTER*1 NAMARY(20,MRows)
  18965. C    COMMON/NMNMNM/NAMARY
  18966.     InTeGer*4 NULAST,LFVD
  18967. C    COMMON/NULXXX/NULAST,LFVD
  18968.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  18969.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  18970. C ***<<< NULETC COMMON END >>>***
  18971. CCC    InTeGer*4 ICREF,IRREF
  18972. CCC    COMMON/MIRROR/ICREF,IRREF
  18973. C
  18974. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  18975. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  18976. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  18977. C AREAS WITH DATA.
  18978. C ***<<< KLSTO COMMON START >>>***
  18979.     InTeGer*4 DLFG
  18980. C    COMMON/DLFG/DLFG
  18981.     InTeGer*4 KDRW,KDCL
  18982. C    COMMON/DOT/KDRW,KDCL
  18983.     InTeGer*4 DTRENA
  18984. C    COMMON/DTRCMN/DTRENA
  18985.     REAL*8 EP,PV,FV
  18986.     DIMENSION EP(20)
  18987.     INTEGER*4 KIRR
  18988. C    COMMON/ERNPER/EP,PV,FV,KIRR
  18989.     InTeGer*4 LASTOP
  18990. C    COMMON/ERROR/LASTOP
  18991.     CHARACTER*1 FMTDAT(9,76)
  18992. C    COMMON/FMTBFR/FMTDAT
  18993.     CHARACTER*1 EDNAM(16)
  18994. C    COMMON/EDNAM/EDNAM
  18995.     InTeGer*4 MFID(2),MFMOD(2)
  18996. C    COMMON/FRM/MFID,MFMOD
  18997.     InTeGer*4 JMVFG,JMVOLD
  18998. C    COMMON/FUBAR/JMVFG,JMVOLD
  18999.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  19000.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  19001. C ***<<< KLSTO COMMON END >>>***
  19002. CCC        CHARACTER*1 FMTDAT(9,76)
  19003. CCC        COMMON/FMTBFR/FMTDAT
  19004.         CHARACTER*1 ITST,ITST2
  19005.     LOGICAL*4 LTST,LTST2
  19006.     InTeGer*4 KTST,KTST2
  19007.     EQUIVALENCE(LTST,ITST),(LTST2,ITST2)
  19008.     EQUIVALENCE(KTST,ITST),(KTST2,ITST2)
  19009.         IF(ID1.LE.27.AND.ID2.LE.1)GOTO 1000
  19010.     IVAL=2
  19011.     IF(LINTGR.EQ.0)RETURN
  19012.     CALL FVLDGT(ID1,ID2,ITST)
  19013.     IF(ICHAR(ITST).EQ.0)GOTO 500
  19014. C        ID=(ID2-1)*60+ID1
  19015.     CALL REFLEC(ID2,ID1,ID)
  19016.         IBT=(ID-1)/8
  19017.     KB1=ID-1
  19018.     KB2=7
  19019.     LB1=LB1.AND.LB2
  19020.     IBIT=KB1+1
  19021. C        IBIT=((ID-1).AND.7)+1
  19022.     KTST=ICHAR(ITYP(IBT))
  19023.     KTST2=ICHAR(LBITS(IBIT))
  19024.     LTST=LTST.AND.LTST2
  19025. C        ITST=CHAR(ICHAR(ITYP(IBT)).AND.ICHAR(LBITS(IBIT)))
  19026. 500     IVAL=2
  19027.         IF(KTST.NE.0)IVAL=4
  19028.         RETURN
  19029. 1000    CONTINUE
  19030. C AN AC. RETURN FULL TYPE WORD
  19031.         IVAL=IATYP(ID1)
  19032.         RETURN
  19033.         END
  19034. c -h- typset.for    Fri Aug 22 13:35:58 1986    
  19035.         SUBROUTINE TYPSET(ID1,ID2,IVAL)
  19036. C
  19037. C TYPSET - STORE IVAL IN TYPE(60,301) ARRAY
  19038. C NEXT BITMAPS IMPLEMENT FVLD
  19039.     Include AParms.inc
  19040.         CHARACTER*1 FV1(IMP1S),FV2(IMP1S),FV4(IMP1S)
  19041.     CHARACTER*1 FVXX(Imps3)
  19042.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  19043.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  19044.         Common/FVLDM/FVXX
  19045. c        COMMON/FVLDM/FV1,FV2,FV4
  19046.         CHARACTER*1 LBITS(8)
  19047.         COMMON/BITS/LBITS
  19048. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  19049. C TYPES OF AC'S STORAGE:
  19050.     LOGICAL*4 LTST,LTST2,LTST3,LT1,LT2
  19051.     InTeGer*4 KTST,KTST2,KTST3,KT1,KT2
  19052.     EQUIVALENCE(LT1,KT1),(LT2,KT2)
  19053.         CHARACTER*1 ITYP(IMP1S)
  19054.         InTeGer*4 IATYP(27),LINTGR
  19055.         COMMON/TYP/IATYP,ITYP,LINTGR
  19056. C ***<<< NULETC COMMON START >>>***
  19057.     InTeGer*4 ICREF,IRREF
  19058. C    COMMON/MIRROR/ICREF,IRREF
  19059.     InTeGer*4 MODPUB,LIMODE
  19060. C    COMMON/MODPUB/MODPUB,LIMODE
  19061.     InTeGer*4 KLKC,KLKR
  19062.     REAL*8 AACP,AACQ
  19063. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  19064.     InTeGer*4 NCEL,NXINI
  19065. C    COMMON/NCEL/NCEL,NXINI
  19066.     CHARACTER*1 NAMARY(20,MRows)
  19067. C    COMMON/NMNMNM/NAMARY
  19068.     InTeGer*4 NULAST,LFVD
  19069. C    COMMON/NULXXX/NULAST,LFVD
  19070.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  19071.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  19072. C ***<<< NULETC COMMON END >>>***
  19073. CCC    InTeGer*4 ICREF,IRREF
  19074. CCC    COMMON/MIRROR/ICREF,IRREF
  19075. C
  19076. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  19077. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  19078. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  19079. C AREAS WITH DATA.
  19080. C ***<<< KLSTO COMMON START >>>***
  19081.     InTeGer*4 DLFG
  19082. C    COMMON/DLFG/DLFG
  19083.     InTeGer*4 KDRW,KDCL
  19084. C    COMMON/DOT/KDRW,KDCL
  19085.     InTeGer*4 DTRENA
  19086. C    COMMON/DTRCMN/DTRENA
  19087.     REAL*8 EP,PV,FV
  19088.     DIMENSION EP(20)
  19089.     INTEGER*4 KIRR
  19090. C    COMMON/ERNPER/EP,PV,FV,KIRR
  19091.     InTeGer*4 LASTOP
  19092. C    COMMON/ERROR/LASTOP
  19093.     CHARACTER*1 FMTDAT(9,76)
  19094. C    COMMON/FMTBFR/FMTDAT
  19095.     CHARACTER*1 EDNAM(16)
  19096. C    COMMON/EDNAM/EDNAM
  19097.     InTeGer*4 MFID(2),MFMOD(2)
  19098. C    COMMON/FRM/MFID,MFMOD
  19099.     InTeGer*4 JMVFG,JMVOLD
  19100. C    COMMON/FUBAR/JMVFG,JMVOLD
  19101.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  19102.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  19103. C ***<<< KLSTO COMMON END >>>***
  19104. CCC        CHARACTER*1 FMTDAT(9,76)
  19105. CCC        COMMON/FMTBFR/FMTDAT
  19106.         CHARACTER*1 ITST,ITST2,ITST3
  19107.     EQUIVALENCE(LTST,ITST),(LTST2,ITST2)
  19108.     EQUIVALENCE(KTST,ITST),(KTST2,ITST2)
  19109.     EQUIVALENCE(KTST3,ITST3),(KTST3,LTST3)
  19110.     IF(ID2.EQ.1.AND.ID1.LE.27)GOTO 2000
  19111. C KEEP TRACK OF WHEN WE START TO SET INTEGER TYPE
  19112.     IF(LINTGR.EQ.0.AND.IABS(IVAL).EQ.2)RETURN
  19113. C FOR SIMPLICITY SET FLAG ON 1ST NONFLOATING TYPE AND
  19114. C START KEEPING EXACT TRACK THEN ONLY.
  19115.     LINTGR=1
  19116. C        ID=(ID2-1)*60+ID1
  19117.     CALL REFLEC(ID2,ID1,ID)
  19118.         IBT=(ID-1)/8
  19119.     KT1=ID-1
  19120.     KT2=7
  19121.     LT1=LT1.AND.LT2
  19122.     IBIT=KT1+1
  19123. C        IBIT=((ID-1).AND.7)+1
  19124.     KTST2=ICHAR(LBITS(IBIT))
  19125.     KTST3=KTST2
  19126.     LTST2=.NOT.LTST2
  19127. C        ITST2=.NOT.LBITS(IBIT)
  19128.     KTST=ICHAR(ITYP(IBT))
  19129.     LTST2=LTST.AND.LTST2
  19130. C        ITST2=ITYP(IBT).AND.ITST2
  19131.     LTST=LTST.OR.LTST3
  19132.     ITST=CHAR(KTST)
  19133.     ITST2=CHAR(KTST2)
  19134. C        ITST=ITYP(IBT).OR.LBITS(IBIT)
  19135.         ITYP(IBT)=ITST2
  19136.         IF(IVAL.NE.-2.AND.IVAL.NE.2)ITYP(IBT)=ITST
  19137.     RETURN
  19138. 2000    IATYP(ID1)=IVAL
  19139. C ACCUMULATORS JUST STORE NORMAL TYPE INTEGER.
  19140.         RETURN
  19141.         END
  19142. c -h- usrcmd.for    Fri Aug 22 13:36:30 1986    
  19143. c        interface to InTeGer*4 function system [c]
  19144. c     +          (string[reference])
  19145. c        character*1 string
  19146. c        end
  19147.     SUBROUTINE USRCMD(CMDLIN,ICODE,IGOTIT)
  19148. C --- FOR 320K AnalytiCalc only (to keep it able to fit on 256K
  19149. c     versions...)
  19150. c Add "annotation" commands via main force & awkwardness as follows:
  19151. c  1. ANN command will create a file named cell.ANN for the current
  19152. c     cell (or overwrite an old one) dynamically for up to 20 lines
  19153. c     of text, just firing up the command "EDIT namecell.ANN" so the user
  19154. c     gets to do full screen edits. THE "name" part of the files is
  19155. c     taken from the first 6 characters of the sheet name. If these
  19156. c     are not in the uppercase alpha range they will be ignored, however,
  19157. c     so it is a good idea for sheet titles to have recognizable initial
  19158. c     6 characters.
  19159. c  2. QUERY or ? command will display the name.ANN file if it exists
  19160. c     after setting cursor to top of screen and doing line erase
  19161. c     there.
  19162. c
  19163.     Include AParms.Inc
  19164.     CHARACTER*81 CMDSTR
  19165.     CHARACTER*1 CMLN(80),CMLN2(84)
  19166. C    PARAMETER CUP=1,EL=12,ED=11,SGR=13
  19167.     InTeGer*4 IJUNK
  19168. c    InTeGer*4 SYSTEM
  19169. c    EXTERNAL SYSTEM
  19170.     EQUIVALENCE(CMLN2(5),CMLN(1),CMDSTR(1:1))
  19171. C    EQUIVALENCE(CMLN2(5),CMLN(1))
  19172. C DUMMY PLACE FOR USER COMMANDS TO PARSE CMDLIN AND HANDLE
  19173. C DEFINE VALUE AREA FOR SPREAD SHEET. MORE WILL BE NEEDED GENERALLY
  19174. C OUT OF COMMONS, BUT AT A MINIMUM, THIS WILL ALLOW SOME ACCESS TO
  19175. C USEFUL NUMBERS. LOOK IN XQTCMD FOR MORE...
  19176.     CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
  19177.     InTeGer*4 TYPE(1,1),VLEN(9)
  19178.     LOGICAL*4 LEXIST
  19179.     CHARACTER*1 NMSH(80)
  19180.     COMMON/NMSH/NMSH
  19181. C ***<<<< RDD COMMON START >>>***
  19182.     InTeGer*4 RRWACT,RCLACT
  19183. C    COMMON/RCLACT/RRWACT,RCLACT
  19184.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  19185.      1  IDOL7,IDOL8
  19186. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  19187. C     1  IDOL7,IDOL8
  19188.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  19189. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  19190.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19191. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19192. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  19193. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  19194.     InTeGer*4 KLVL
  19195. C    COMMON/KLVL/KLVL
  19196.     InTeGer*4 IOLVL,IGOLD
  19197. C    COMMON/IOLVL/IOLVL
  19198. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  19199. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  19200.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19201.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19202.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  19203.      3  k3dfg,kcdelt,krdelt,kpag
  19204. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19205. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19206. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  19207. C ***<<< RDD COMMON END >>>***
  19208. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  19209. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  19210.     REAL*8 XAC,XVBLS(1,1)
  19211.     REAL*8 TAC,UAC,VAC
  19212.     INTEGER*4 JVBLS(2,1,1)
  19213.     EQUIVALENCE(XAC,AVBLS(1,27))
  19214.     EQUIVALENCE(TAC,AVBLS(1,20))
  19215.     EQUIVALENCE(UAC,AVBLS(1,21))
  19216.     EQUIVALENCE(VAC,AVBLS(1,22))
  19217.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  19218.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  19219.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  19220. C    CHARACTER*1 FORM(4)
  19221.     CHARACTER*1 CELNAM(5)
  19222.     character*18 annam
  19223.     CHARACTER*1 annams(18)
  19224.     equivalence(annam(1:1),annams(1))
  19225.     CHARACTER*5 CELNM
  19226.     CHARACTER*5 CELRW
  19227.     EQUIVALENCE(CELNM(1:1),CELRW(1:1),CELNAM(1))
  19228. C    EQUIVALENCE(FORM(1),CELNAM(1))
  19229. C    EQUIVALENCE(CELRW,CELNAM(1))
  19230. C ***<<< KLSTO COMMON START >>>***
  19231.     InTeGer*4 DLFG
  19232. C    COMMON/DLFG/DLFG
  19233.     InTeGer*4 KDRW,KDCL
  19234. C    COMMON/DOT/KDRW,KDCL
  19235.     InTeGer*4 DTRENA
  19236. C    COMMON/DTRCMN/DTRENA
  19237.     REAL*8 EP,PV,FV
  19238.     DIMENSION EP(20)
  19239.     INTEGER*4 KIRR
  19240. C    COMMON/ERNPER/EP,PV,FV,KIRR
  19241.     InTeGer*4 LASTOP
  19242. C    COMMON/ERROR/LASTOP
  19243.     CHARACTER*1 FMTDAT(9,76)
  19244. C    COMMON/FMTBFR/FMTDAT
  19245.     CHARACTER*1 EDNAM(16)
  19246. C    COMMON/EDNAM/EDNAM
  19247.     InTeGer*4 MFID(2),MFMOD(2)
  19248. C    COMMON/FRM/MFID,MFMOD
  19249.     InTeGer*4 JMVFG,JMVOLD
  19250. C    COMMON/FUBAR/JMVFG,JMVOLD
  19251.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  19252.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  19253. C ***<<< KLSTO COMMON END >>>***
  19254. CCC    CHARACTER*1 EDNAM(16)
  19255. CCC    common/ednam/ednam
  19256. c available parsing aid:
  19257. c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid)
  19258. c where line(ibgn... lend) is scanned. If variable found
  19259. c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for
  19260. c variable found if any. lstchr is last char found+1...
  19261. C OTHER USEFUL ROUTINES IN THE SHEET:
  19262. C GN(LAST,LEND,NUMBER,LINE)
  19263. C  LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND
  19264. C  RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A
  19265. C  BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND
  19266. C  HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON
  19267. C  NUMERIC.
  19268. C INDEX(LINE,CHAR)
  19269. C  EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER
  19270. C  THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE
  19271. C  MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR).
  19272. C  NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH
  19273. C  RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH
  19274. C  FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER...
  19275. C  PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE
  19276.     CHARACTER*1 CMDLIN(132)
  19277. C    INTEGER*4 ISTTS
  19278. C
  19279. C 16 MUST BE LENGTH OF EDNAM IN BYTES
  19280. C KEEP NAME "EDIT " IN DATA SO IT CAN BE BASHED IF NEEDED TO BE...
  19281. C INSERT CODE FOR ADDING A LIB$SPAWN CALL HERE TO PASS COMMANDS TO
  19282. C 75 IF THEY BEGIN WITH A $ CHARACTER.
  19283.     IGOTIT=0
  19284.     IF(CMDLIN(1).NE.'}'.AND.CMDLIN(1).NE.'$')GOTO 8990
  19285. C
  19286. CC HERE CALL EXECIT WITH THE COMMAND LINE AS AN ARGUMENT...
  19287.     DO 1000 NN=1,80
  19288. 1000    CMLN(NN)=CMDLIN(NN+1)
  19289.     CMLN(79)=Char(13)
  19290.     CMLN(80)=Char(0)
  19291.     DO 1002 NN=1,77
  19292.     N=78-NN
  19293.     IF(ICHAR(CMLN(N)).GT.32)GOTO 1004
  19294. 1002    CONTINUE
  19295. C FINDING END OF REAL STRING THIS WAY
  19296. 1004    CONTINUE
  19297.     CMLN(N+1)=0
  19298. c was =13, not =0 above...
  19299. C ADD C.R., THEN NULL
  19300.     CMLN(N+2)=0
  19301.     CMLN(N+3)=0
  19302. C INSERT LENGTH COUNT AS 1ST BYTE OF CMD LENGTH
  19303. C PER DOS 2.0 MANUAL PG F-1
  19304. ccc    CMLN2(1)=CHAR(N+3)
  19305. ccc    CMLN2(2)='/'
  19306. ccc    CMLN2(3)='C'
  19307. ccc    CMLN2(4)=' '
  19308. CC ! ADD C.R. AFTER LINE
  19309. CC ABOVE, INSERT A CR AFTER CMD LINE
  19310. C USE SYSTEM CALL INSTEAD OF OLDER CALL WHICH USES NOW-UNSUPPORTED
  19311. C FORTRAN FEATURES IN MS-FORTRAN V3.3
  19312.     call system(cmln2(5))
  19313. c    N=SYSTEM(CMLN2(5))
  19314. ccc    CALL EXECIT(CMLN2)
  19315. C ASSUME WE NEED A REDRAW AFTER THE SPAWN FINISHES
  19316. C EVENTUALLY FIGURE OUT HOW TO EXEC A ROUTINE THIS WAY, BUT JUST DUMMY OUT
  19317. C  AT FIRST.
  19318.     IF(CMDLIN(1).NE.'}')GOTO 2300
  19319. C IMPLEMENT WAIT ON } FORM...
  19320.     CALL UVT100(1,25,1)
  19321.     CALL VWRT('Push Return key to return to sheet>',35)
  19322.     call vget(ijunk,2)
  19323. c    READ(11,2400,END=2300,ERR=2300)IJUNK
  19324. 2400    FORMAT(2A1)
  19325. 2300    CONTINUE
  19326.     ICODE=2
  19327. C FLAG THE MAIN COMMAND PARSER WE HANDLED THE COMMAND
  19328.     IGOTIT=1
  19329. 8990    CONTINUE
  19330.     IF(CMDLIN(1).NE.'F'.OR.
  19331.      1     CMDLIN(2).NE.'I'.OR.
  19332.      2     CMDLIN(3).NE.'L') GOTO 9000
  19333.     IGOTIT=1
  19334.     ICODE=3
  19335.     CALL DTRCMD(CMDLIN(4))
  19336. C ALLOW EXTRA COMMANDS OUT OF VAX VERSION...
  19337. C
  19338. 9000    CONTINUE
  19339.     IF(CMDLIN(1).NE.'A'.OR.CMDLIN(2).NE.'N')GOTO 9200
  19340. C ANNOTATE COMMAND SEEN
  19341.     IGOTIT=1
  19342.     ICODE=2
  19343.     DO 9001 N=1,80
  19344.     CMLN(N)=Char(32)
  19345. 9001    CONTINUE
  19346. C    CALL IN2AS(PROW,FORM)
  19347.     CALL REFLEC(PCOL,PROW,IRX)
  19348.     WRITE(CELRW(1:5),9002)IRX
  19349. 9002    FORMAT(I5.5)
  19350.     ICM=17
  19351.     DO 9040 N=1,3
  19352.     IXX=ICHAR(NMSH(N))
  19353.     IF(IXX.GT.96)IXX=IXX-32
  19354.     IF(IXX.LT.65.OR.IXX.GT.90)GOTO 9040
  19355.     CMLN(ICM)=CHAR(IXX)
  19356.     ICM=ICM+1
  19357. 9040    CONTINUE
  19358.     ICM=ICM-1
  19359.     DO 9003 N=1,5
  19360.     CMLN(N+ICM)=CELNAM(N)
  19361. 9003    CONTINUE
  19362.     CMLN(ICM+6)='.'
  19363.     CMLN(ICM+7)='A'
  19364.     CMLN(ICM+8)='N'
  19365.     CMLN(ICM+9)='N'
  19366.     CMLN(ICM+10)=' '
  19367.     CMLN(80)=13
  19368.     DO 9008 N=1,16
  19369.     CMLN(N)=EDNAM(N)
  19370. 9008    CONTINUE
  19371. C NOW HAVE "EDIT name.ANN"
  19372. c built... go fire it up for creation or modification of annotation...
  19373.     DO 9150 N=17,ICM+9
  19374.     IF(CMLN(N).EQ.' ')CMLN(N)='0'
  19375. 9150    CONTINUE
  19376.     DO 9162 NN=1,77
  19377.     N=78-NN
  19378.     IF(ICHAR(CMLN(N)).GT.32)GOTO 9164
  19379. 9162    CONTINUE
  19380. C FINDING END OF REAL STRING THIS WAY
  19381. 9164    CONTINUE
  19382.     CMLN(N+1)=Char(13)
  19383. C ADD C.R., THEN NULL
  19384.     CMLN(N+2)=Char(0)
  19385.     CMLN(N+3)=Char(0)
  19386.     N=SYSTEM(CMLN2(5))
  19387.     GOTO 9990
  19388. 9200    CONTINUE
  19389.     IF(CMDLIN(1).NE.'?'.AND.(CMDLIN(1).NE.'Q'.OR.CMDLIN(2)
  19390.      1  .NE.'U'.OR.CMDLIN(3).NE.'E')) GOTO 9300
  19391. C QUERY COMMAND SEEN
  19392.     IGOTIT=1
  19393.     ICODE=2
  19394.     DO 9237 N=1,18
  19395. 9237    ANNAMS(N)=CHAR(32)
  19396.     CALL REFLEC(PCOL,PROW,IRX)
  19397.     WRITE(CELRW(1:5),9002)IRX
  19398.     ICM=0
  19399.     do 9238 n=1,18
  19400.     annams(n)=char(32)
  19401. 9238    continue
  19402.     DO 9240 N=1,3
  19403. C NOTE ANNOTATION NAMES ARE DIFFERENT HERE FROM VAX...
  19404. C USE NAMnnnnn.ANN WHERE nnnnn IS CELL HASH AND "NAM" COMES
  19405. C FROM 1ST 3 CHARS OF SHEET TITLE.
  19406.     IXX=ICHAR(NMSH(N))
  19407.     IF(IXX.GT.96)IXX=IXX-32
  19408.     IF(IXX.LT.65.OR.IXX.GT.90)GOTO 9240
  19409.     ICM=ICM+1
  19410.     ANNAMS(ICM)=CHAR(IXX)
  19411. 9240    CONTINUE
  19412.     DO 9241 N=1,5
  19413.     ANNAMS(ICM+N)=CELNAM(N)
  19414. 9241    CONTINUE
  19415.     ANNAMS(ICM+6)='.'
  19416.     ANNAMS(ICM+7)='A'
  19417.     ANNAMS(ICM+8)='N'
  19418.     ANNAMS(ICM+9)='N'
  19419.     DO 9250 N=1,18
  19420.     IF(ANNAMS(N).EQ.' ')ANNAMS(N)='0'
  19421. 9250    CONTINUE
  19422.     ANNAMS(ICM+10)=' '
  19423. C GO TO 9210 IF NO FILE
  19424.     INQUIRE (FILE=ANNAM,EXIST=LEXIST)
  19425.     IF(.NOT.LEXIST)GOTO 9210
  19426.     OPEN(UNIT=2,FILE=ANNAM,ACCESS='SEQUENTIAL',STATUS='OLD')
  19427.     DO 9030 N=1,20
  19428.     READ(2,9031,END=9032,ERR=9032)WRK
  19429. 9031    FORMAT(128A1)
  19430.     CALL UVT100(1,N+2,1)
  19431.     CALL UVT100(12,2,0)
  19432.     call swrt(wrk,79)
  19433. c    WRITE(6,9035)WRK
  19434. 9035    FORMAT(128A1)
  19435. 9030    CONTINUE
  19436. 9032    CONTINUE
  19437. C THIS DISPLAYS ALL THE ANNOTATION WE HAVE...
  19438.     CLOSE(UNIT=2)
  19439.     CALL UVT100(1,LLCMD,1)
  19440.     CALL UVT100(12,2,0)
  19441.     CALL VWRT('Push Return key to return to sheet>',35)
  19442.     call vget(ijunk,2)
  19443. c    READ(11,2400,END=9990,ERR=9990)IJUNK
  19444.     GOTO 9990
  19445. 9210    CONTINUE
  19446.     ICODE=3
  19447.     CALL UVT100(1,LLDSP,1)
  19448.     call uvt100(12,2,0)
  19449.     CALL SWRT('No Annotation found on thic cell.',33)
  19450. c    WRITE(6,9211)
  19451. c9211    FORMAT(' No annotation found on this cell.')
  19452. 9300    CONTINUE
  19453. C
  19454. 9990    CONTINUE
  19455.     RETURN
  19456.     END
  19457. c -h- usrfct.for    Fri Aug 22 13:36:30 1986    
  19458. C USER FUNCTION ROUTINE
  19459. C GENERATES PARSING AND EXECUTION OF ROUTINE CALLS OF FORM
  19460. C  *U FNAME (ARGUMENTS)
  19461. C WHERE LINE (80 BYTES) CONTAINS COMMAND LINE AND ALL
  19462. C ARGUMENTS MAY BE PARSED.
  19463. C CALLED FROM CMND
  19464. C
  19465. C VAX VERSION: MOST MATRIX ROUTINES AVAILABLE
  19466. C BUT ASSUMES SUBSTANTIAL SPACE AVAILABLE.
  19467. C
  19468. c available parsing aid:
  19469. c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid)
  19470. c where line(ibgn... lend) is scanned. If variable found
  19471. c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for
  19472. c variable found if any. lstchr is last char found+1...
  19473. C OTHER USEFUL ROUTINES IN THE SHEET:
  19474. C GN(LAST,LEND,NUMBER,LINE)
  19475. C  LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND
  19476. C  RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A
  19477. C  BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND
  19478. C  HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON
  19479. C  NUMERIC.
  19480. C INDEX(LINE,CHAR)
  19481. C  EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER
  19482. C  THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE
  19483. C  MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR).
  19484. C  NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH
  19485. C  RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH
  19486. C  FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER...
  19487. C  PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE
  19488. C VARIABLE NAMES. SUPPLIED VERSION CALLS IDATE WHICH RETURNS
  19489. C SYSTEM DATE IN RSX OR VMS AS INTEGER DAY, MONTH, AND YEAR.
  19490. C  THIS RETURNS HERE IN AC T, U, AND V
  19491. C
  19492.     SUBROUTINE USRFCT(LINE,RETCD,WRK2)
  19493.     Include AParms.inc
  19494.     CHARACTER*1 LINE(80)
  19495.     INTEGER RETCD
  19496.     CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
  19497.     CHARACTER*1 WRK2(128)
  19498.     InTeGer*4 TYPE(1,1),VLEN(9)
  19499.     EXTERNAL INDX
  19500.     REAL*8 XAC,XVBLS(1,1)
  19501.     REAL*8 TAC,UAC,VAC,WAC,YAC
  19502.     REAL*8 TMP,XXXX
  19503.     INTEGER*4 JVBLS(2,1,1)
  19504.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  19505.     EQUIVALENCE(XAC,AVBLS(1,27))
  19506.     EQUIVALENCE(TAC,AVBLS(1,20))
  19507.     EQUIVALENCE(UAC,AVBLS(1,21))
  19508.     EQUIVALENCE(VAC,AVBLS(1,22))
  19509.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  19510.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  19511.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  19512. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  19513. CCC    CHARACTER*1 XTNCMD(80)
  19514. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  19515. C ***<<<< RDD COMMON START >>>***
  19516.     InTeGer*4 RRWACT,RCLACT
  19517. C    COMMON/RCLACT/RRWACT,RCLACT
  19518.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  19519.      1  IDOL7,IDOL8
  19520. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  19521. C     1  IDOL7,IDOL8
  19522.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  19523. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  19524.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19525. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19526. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  19527. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  19528.     InTeGer*4 KLVL
  19529. C    COMMON/KLVL/KLVL
  19530.     InTeGer*4 IOLVL,IGOLD
  19531. C    COMMON/IOLVL/IOLVL
  19532. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  19533. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  19534.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19535.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19536.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  19537.      3  k3dfg,kcdelt,krdelt,kpag
  19538. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19539. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19540. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  19541. C ***<<< RDD COMMON END >>>***
  19542. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  19543. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  19544. CCC    InTeGer*4 RRWACT,RCLACT
  19545. CCC    COMMON/RCLACT/RRWACT,RCLACT
  19546. C ***<<< XVXTCD COMMON START >>>***
  19547.     CHARACTER*1 OARRY(100)
  19548.     InTeGer*4 OSWIT,OCNTR
  19549. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  19550. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  19551.     InTeGer*4 IPS1,IPS2,MODFLG
  19552. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  19553.        InTeGer*4 XTCFG,IPSET,XTNCNT
  19554.        CHARACTER*1 XTNCMD(80)
  19555. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  19556. C VARY FLAG ITERATION COUNT
  19557.     INTEGER KALKIT
  19558. C    COMMON/VARYIT/KALKIT
  19559.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  19560.     InTeGer*4 RCMODE,IRCE1,IRCE2
  19561.  
  19562. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  19563. C     1  IRCE2
  19564. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  19565. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  19566. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  19567. C RCFGX ON.
  19568. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  19569. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  19570. C  AND VM INHIBITS. (SETS TO 1).
  19571.     INTEGER*4 FH
  19572. C FILE HANDLE FOR CONSOLE I/O (RAW)
  19573. C    COMMON/CONSFH/FH
  19574.     CHARACTER*1 ARGSTR(52,4)
  19575. C    COMMON/ARGSTR/ARGSTR
  19576.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  19577.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  19578.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  19579.      3  IRCE2,FH,ARGSTR
  19580. C ***<<< XVXTCD COMMON END >>>***
  19581. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  19582. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  19583. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  19584. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  19585. C (IMPLEMENT FOR VAX ONLY)
  19586. CCC    INTEGER KALKIT
  19587. CCC    COMMON/VARYIT/KALKIT
  19588. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  19589. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  19590. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  19591. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  19592.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  19593.     COMMON/D2R/NRDSP,NCDSP
  19594.     CHARACTER*1 FNAMS(6,24)
  19595. C FNAMS IS NAME OF FUNCTION CALLED.
  19596.     DATA FNAMS /'I','D','A','T','E','0',
  19597.      1  'M','T','X','E','Q','0',
  19598.      2  'M','O','V','E','V','0',
  19599.      3  'M','D','E','T','0','0',
  19600.      4  'M','P','R','O','D','0',
  19601.      5  'M','A','D','D','V','0','M','S','U','B','V','0',
  19602.      7  'M','M','P','Y','T','0','M','M','P','Y','C','0',
  19603.      9  'V','A','R','Y','0','0','X','Q','T','C','M','0',
  19604.      2  'S','T','R','V','L','0','H','E','R','E','0','0',
  19605.      4  'Y','R','M','O','D','0','J','D','A','T','E','0',
  19606.      6  'J','T','O','C','H','0','D','A','T','E','0','0',
  19607.      1  'W','K','D','Y','S','0','W','K','D','I','N','0',
  19608.      2  'F','F','T','F','W','0','F','F','T','R','V','0',
  19609.      3  'L','I','N','E','F','0','D','B','0','0','0','0',
  19610.      4  'S','T','0','0','0','0'/
  19611. C NULL TERMINATE ANY NAMES (ALLOWS 5 CHARACTERS)
  19612. C START LOOKING PAST THE *U
  19613. C  GET FUNCTION NAME AND GO TO PROCESS EACH FUNCTION SEPARATELY
  19614. C GET NONBLANK CHAR FOR FUNCTION NAME START
  19615. C NO-OP THE XQTCM FUNCTION FOR PDP11-OVERLAIN VERSIONS BY ZAPPING
  19616. C THE NAME SO IT CAN'T EVER BE CALLED.
  19617.     K=3
  19618. 30    IF(LINE(K).NE.' ')GOTO 40
  19619.     K=K+1
  19620.     IF(K.LT.60)GOTO 30
  19621. 40    CONTINUE
  19622. C UNCOMMENT THE DO 100 STMT IF DIM 2 OF FNAMS > 1
  19623.     N=1
  19624. C **** BE SURE THE 2ND BOUND ON N IS THE SAME AS THE DIMENSION OF
  19625. C ****  FNAMS   **************************
  19626. C    DO 7771 N=1,24
  19627. C    DO 7771 NN=1,6
  19628. C    IF(FNAMS(NN,N).EQ.'0')FNAMS(NN,N)=0
  19629. C7771    CONTINUE
  19630.     DO 100 N=1,24
  19631.     KF=N
  19632.     DO 110 NN=1,6
  19633. C CHECK FOR '0' IN FUNCTION NAME AND SKIP ON THAT... 48 IS ASCII /0/
  19634.     IF(LINE(K+NN-1).NE.FNAMS(NN,N).AND.ICHAR(FNAMS(NN,N)).NE.48)
  19635.      1  GOTO 100
  19636. 110    CONTINUE
  19637.     GOTO 200
  19638. 100    CONTINUE
  19639. C UNRECOGNIZED FUNCTION... IGNORE
  19640. 300    RETCD=3
  19641.     RETURN
  19642. 200    CONTINUE
  19643. C NOW HAVE FOUND FUNCTION IDENTIFIED BY KF. CALL IT AND ALLOW TO WORK
  19644.     GOTO (1100,1200,1300,1400,1500,1600,1700,1800,
  19645.      1  1900,2000,2100,2200,2300,2400,2500,2600,2700,
  19646.      2  2900,3000,3100,3200,3300,3400,3500),KF
  19647.     GOTO 300
  19648. 1100    CONTINUE
  19649. C IDATE FUNCTION
  19650. C RETURNS MONTH, DAY, YEAR IN AC'S T,U,V
  19651. C RETURN 4/1/85 (APRIL FOOLS DAY)
  19652. C    IDA=1
  19653. C    IMO=4
  19654. C    IYR=85
  19655. C    CALL IDATE(IMO,IDA,IYR)
  19656.     CALL DATE(IYR,IMO,IDA)
  19657. C CALL supplied GET-DATE FUNCTION AND HOPE IT'S OK
  19658.     TAC=IMO
  19659.     UAC=IDA
  19660.     IYR=IYR-1900
  19661.     VAC=IYR
  19662. C RETURN A FLOATING VALUE OF DATE FORM AS YYMMDD SO IT CAN BE
  19663. C USED FOR SORTING AND SIMILAR APPLICATIONS. COULD BE USED ALSO
  19664. C FOR INTERVALS IF A JULIAN DATE WERE RETURNED, BUT THIS WILL DO
  19665. C FOR COMPARISONS AND ORDERING.
  19666.     XAC=JULMDY(IYR,IMO,IDA)
  19667. C    XAC=VAC*10000.+TAC*100.+UAC
  19668.     RETURN
  19669. 1200    CONTINUE
  19670. C MATRIX EQUATION. NOTE WE MUST NOW START SCAN FOR ARGUMENTS...
  19671. C K+5 IS START OF ARG LIST. START AT K+6 TO ALLOW ( TO BE THERE...
  19672. C FORMAT DESIRED:
  19673. C  *U MTXEQ(A1:A2,X1:X2,B1:B2) GENERATING SOLUTION MATRIX X1:X2
  19674. C  FROM MATRICES A,B AND SOLVING EQUATION AX=B WHERE A IS AN N BY
  19675. C  N SQUARE MATRIX, AND X AND B ARE N BY M MATRICES.
  19676.     RETCD=1
  19677. C COLLECT ARGUMENTS. NOTE THAT VARSCN AND GN TRASH POINTERS PASSED
  19678. C TO THEM IN IBGN, LEND, SO MAKE UP EVERY TIME. USE VARSCN TO
  19679. C COLLECT POINTERS TO THE SHEET ARRAY FIRST OFF COMMAND LINE,
  19680. C THEN PROCESS IN OUR MAGICAL MYSTICAL ROUTINE...
  19681.     IBGN=K+6
  19682.     LEND=IBGN+20
  19683. C GET LOCATIONS OF MATRICES A, X, AND B (FOR AX=B EQN)
  19684. C A MUST BER N BY N, SQUARE. X,B ARE N BY M.
  19685.     CALL PMTX2(RETCD,3,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  19686.      1   IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  19687.     N=IABS(ID1B-ID1A)+1
  19688. C CHECK THAT MATRIX A IS SQUARE
  19689.     IF(N.NE.(IABS(ID2B-ID2A)+1))GOTO 300
  19690. C CHECK THAT MATRIX X AND B HAVE THE SAME DIMENSIONS
  19691.     IF((IDYA-IDXA).NE.(IDCA-IDBA))GOTO 300
  19692.     IF((IDYB-IDXB).NE.(IDCB-IDBB))GOTO 300
  19693.     M=IABS(IDYA-IDXA)+1
  19694. C CHECK THAT THE X AND B MATRIX DIMENSIONS ARE N BY M
  19695. C WHERE THE N IS THE SAME AS FOR THE A MATRIX
  19696.     NN=IABS(IDYB-IDXB)+1
  19697.     IF(NN.NE.N)GOTO 300
  19698. C NOW HAVE DIMENSIONS FOR ALL THIS STUFF...
  19699. C SINCE MTXEQU TRASHES ITS' B MATRIX, COPY IT INTO X MATRIX
  19700. C AND THEN CALL...
  19701.     DO 1210 NN=IDBA,IDCA
  19702.     DO 1210 MM=IDBB,IDCB
  19703.     CALL XVBLGT(NN,MM,XVBLS(1,1))
  19704.     CALL XVBLST(NN-IDBA+IDXA,MM-IDBB+IDXB,XVBLS(1,1))
  19705. C    XVBLS(NN-IDBA+IDXA,MM-IDBB+IDXB)=XVBLS(NN,MM)
  19706. 1210    CONTINUE
  19707. C NOW ALL THE ARGUMENTS ARE SET UP... GO DO THE WORK.
  19708. C CALL UTILITY ROUTINE, THEN DONE...
  19709.     CALL MTXEQU(ID1A,ID2A,IDXA,IDXB,N,M,XAC)
  19710.     RETURN
  19711. 1300    CONTINUE
  19712. C MOVEV  MTX1 MTX2  MOVE MTX1 VALUES TO MTX2
  19713.     RETCD=1
  19714.     IBGN=K+6
  19715.     CALL PMTX2(RETCD,2,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,IR2T,IC2T,
  19716.      1  IR2B,IC2B,KK,KK,KK,KK)
  19717. C CHECK FOR SAME SIZE MATRICES
  19718.     IF((IC1T-IC1B).NE.(IC2T-IC2B))GOTO 300
  19719.     IF((IR1T-IR1B).NE.(IR2T-IR2B))GOTO 300
  19720. C DO THE COPY HERE (EASIER THAN CALLING SOMETHING...)
  19721.     DO 1301 NN=IR1T,IR1B
  19722.     DO 1301 MM=IC1T,IC1B
  19723.     CALL XVBLGT(NN,MM,XVBLS(1,1))
  19724.     CALL XVBLST(NN-IR1T+IR2T,MM-IC1T+IC2T,XVBLS(1,1))
  19725. C    XVBLS(NN-IR1T+IR2T,MM-IC1T+IC2T)=XVBLS(NN,MM)
  19726. 1301    CONTINUE
  19727.     RETURN
  19728. 1400    CONTINUE
  19729. C MDET  - DETERMINANT OF SQUARE MATRIX
  19730. C  1 ARGUMENT, VIZ., MATRIX COORDS
  19731.     RETCD=1
  19732. C ACCOUNT FOR "MDET" BEING 4 CHARS NOT 5
  19733.     IBGN=K+5
  19734.     CALL PMTX2(RETCD,1,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,
  19735.      1  IV,IV,IV,IV,IV,IV,IV,IV)
  19736. C CALL A DETERMINANT ROUTINE TO DO THE WORK
  19737. C NOTE IT CHECKS FOR SQUARE MATRIX INTERNALLY AND RETURNS 0 IF NOT
  19738. C SQUARE...
  19739.     CALL MDET(XVBLS,IR1T,IC1T,IR1B,IC1B,XAC)
  19740.     RETURN
  19741. 1500    CONTINUE
  19742. C MPROD A,B,C  C=A*B MATRIX WISE
  19743.     IBGN=K+6
  19744.     RETCD=1
  19745.     IMXX=3
  19746.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  19747.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  19748. C A=N BY M
  19749. C B=M BY L
  19750. C C=N BY L
  19751.     N=1+ID1B-ID1A
  19752.     M=1+ID2B-ID2A
  19753. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  19754.     L=1+IDYA-IDXA
  19755. C    IF(N.NE.(1+IDCB-IDBB))GOTO 300
  19756. C    IF(L.NE.(1+IDCA-IDBA))GOTO 300
  19757. C DIMENSIONS LOOK OK NOW SO DO THE WORK
  19758. C USE SLIGHTLY MODIFIED GMPRD
  19759.     CALL GMPRD(ID1A,ID2A,IDXA,IDXB,
  19760.      1  IDBA,IDBB,N,M,L)
  19761.     RETURN
  19762. 1600    CONTINUE
  19763. C MADDV A,B,C  C=A+B
  19764.     IMXX=3
  19765.     IBGN=K+6
  19766.     RETCD=1
  19767.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  19768.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  19769.     N=1+ID1B-ID1A
  19770.     M=1+ID2B-ID2A
  19771. C    IF(N.NE.(1+IDYA-IDXA))GOTO 300
  19772. C    IF(N.NE.(1+IDCA-IDBA))GOTO 300
  19773. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  19774. C    IF(M.NE.(1+IDCB-IDBB))GOTO 300
  19775. C USE MODIFIED GMADD
  19776.     CALL GMADD(ID1A,ID2A,IDXA,IDXB,
  19777.      1  IDBA,IDBB,M,N)
  19778.     RETURN
  19779. 1700    CONTINUE
  19780. C MSUBV A,B,C  C=A-B
  19781.     IMXX=3
  19782.     IBGN=K+6
  19783.     RETCD=1
  19784.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  19785.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  19786.     N=1+ID1B-ID1A
  19787.     M=1+ID2B-ID2A
  19788. C    IF(N.NE.(1+IDYA-IDXA))GOTO 300
  19789. C    IF(N.NE.(1+IDCA-IDBA))GOTO 300
  19790. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  19791. C    IF(M.NE.(1+IDCB-IDBB))GOTO 300
  19792.     CALL GMSUB(ID1A,ID2A,IDXA,IDXB,
  19793.      1  IDBA,IDBB,M,N)
  19794.     RETURN
  19795. 1800    CONTINUE
  19796. C MMPYT A,B,C  C=AT*B
  19797. C GET 3 MATRICES
  19798.     IMXX=3
  19799.     IBGN=K+6
  19800.     RETCD=1
  19801.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  19802.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  19803. C TRANSPOSE DIMENSIONS OF A...
  19804.     M=1+ID1B-ID1A
  19805.     N=1+ID2B-ID2A
  19806. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  19807.     L=1+IDYA-IDXA
  19808. C    IF(N.NE.(1+IDCB-IDBB))GOTO 300
  19809. C    IF(L.NE.(1+IDCA-IDBA))GOTO 300
  19810.     CALL GTPRD(ID1A,ID2A,IDXA,IDXB,
  19811.      1  IDBA,IDBB,N,M,L)
  19812.     RETURN
  19813. 1900    CONTINUE
  19814. C MMPYC A,B,K  B=A*K (K=CONSTANT)
  19815. C FOR MPY BY CONSTANT WE GET MATRICES IN ORDER A,C, THEN AC WITH CONST
  19816. C IN IT LAST...
  19817.     IBGN=K+6
  19818.     RETCD=1
  19819.     IMXX=2
  19820.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  19821.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  19822.     IF(LINE(IBGN-1).NE.',')GOTO 300
  19823.     LEND=IBGN+20
  19824.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,IDCA,IDCB,IVALID)
  19825.     IF(IVALID.EQ.0)GOTO 300
  19826. C NOW HAVE EVERYTHING OF ARGS... CHECK DIMENSIONS OF MATRICES....
  19827.     N=1+ID1B-ID1A
  19828.     M=1+ID2B-ID2A
  19829. C    IF(N.NE.(1+IDYA-IDXA))GOTO 300
  19830. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  19831.     CALL XVBLGT(IDCA,IDCB,XXXX)
  19832.     DO 1901 NN=ID1A,ID1B
  19833.     DO 1901 MM=ID2A,ID2B
  19834.     CALL XVBLGT(NN,MM,XVBLS(1,1))
  19835.     XVBLS(1,1)=XVBLS(1,1)*XXXX
  19836.     CALL XVBLST(NN-ID1A+IDXA,MM-ID2A+IDXB,XVBLS(1,1))
  19837. C    XVBLS(NN-ID1A+IDXA,MM-ID2A+IDXB)=XVBLS(NN,MM)
  19838. C     1    *XVBLS(IDCA,IDCB)
  19839. 1901    CONTINUE
  19840.     RETURN
  19841. C *U VARY X,A,W,I,P;Q;R;S;T
  19842. C  REPEATEDLY COMPUTE SHEET FOR I ITERATIONS (DEFAULTS TO 1
  19843. C  IF NONE GIVEN) AND VARY AC P,Q,R,S, T (POSITIONAL...WHATEVER
  19844. C  IS NAMED) UNTIL CONDITION THAT AC X (WHATEVER IS NAMED THERE)
  19845. C  IS MADE EQUAL TO AC A AS CLOSELY AS POSSIBLE. DOES MULTI-DIMENSIONAL
  19846. C  STEPPING SEARCH SAVING AC'S AND MODIFYING. ACTUALLY WILL HANDLE ANY
  19847. C  CELL. UP TO 8 DIMENSIONS PERMITTED (ARBITRARY LIMIT).
  19848. C  NOTE THAT RECALCULATE SPECIAL VARY FLAG WILL BE SET HERE IF
  19849. C  VARYING MORE THAN ONCE...
  19850. C  WILL VARY ONE OF THE AC'S IN THE LIST P,Q,R,S,T... BY INITIAL
  19851. C  FRACTION W (AN ARBITRARY "STEP SIZE" FRACTION) AND COMPUTE THE
  19852. C  GRADIENT OF (X-A) WRT THAT AC, THEN WILL REPLACE ALL AC'S AND
  19853. C  VARY THAT AC BY W * THE GRADIENT, MEANING THAT AS THE GRADIENT
  19854. C  DECREASES, THE VARIANCE DOES ALSO. LAST GRADIENTS ARE SAVED AND
  19855. C  USED AS INITIAL VARIANCES, SO THAT THE W FRACTION IS AN INITIAL
  19856. C  GUESS. HOWEVER IT ALSO IS A LIMIT SO NO STEP VARIES AN AC BY
  19857. C  MORE FRACTIONALLY THAN W.
  19858. C   ONCE THIS IS DONE ANOTHER ONE OF THE P,Q,R,S,T,... LIST IS
  19859. C  CHOSEN CIRCULARLY AND THE PROCESS REPEATS. THIS MAY CONTINUE
  19860. C  INDEFINITELY TO LOOK FOR CONVERGENCE.
  19861. C   NOTE THAT X AND A MAY BE ANY CELL AND NEED NOT BE ACCUMULATORS.
  19862. C  HOWEVER ALL OTHER CELLS TO VARY MUST BE AC'S AND MUST BE THE
  19863. C  INDEPENDENT VARIABLES. CALCULATIONS ELSEWHERE ON THE SHEET
  19864. C  (PERHAPS LATER IN THE SAME CELL...)MUST ESTABLISH DEPENDENT
  19865. C  VARIABLES OR BOUNDARY OR NORMALIZATION CONDITIONS.
  19866. 2000    CONTINUE
  19867.     RETCD=1
  19868. C SPLIT OFF THESE FUNCTIONS INTO A COMMON SUBROUTINE
  19869.     CALL VVARY(LINE,RETCD,K)
  19870.     RETURN
  19871. 2100    CONTINUE
  19872. C EXECUTE COMMAND. FILL IN COMMAND FROM GIVEN FUNCTION AND
  19873. C CALL XQTCMD TO DO IT. SETS UP NECESSARY VARIABLES FIRST.
  19874. C ASSUME THE COMMAND LINE MUST BE ALONE ON LINE AFTER THIS CALL...
  19875.     KK=1
  19876.     KKK=K+6
  19877.     DO 2101 NN=KKK,80
  19878.     XTNCMD(KK)=LINE(NN)
  19879.     IF(ICHAR(XTNCMD(KK)).LE.0)GOTO 2102
  19880.     KK=KK+1
  19881. 2101    CONTINUE
  19882. 2102    CONTINUE
  19883.     XTNCMD(KK+1)=0
  19884.     XTNCMD(KK+2)=0
  19885.     XTNCNT=KK
  19886.     XTCFG=1
  19887.     IPSET=1
  19888.     CALL XQTCMD(ICODE)
  19889.     RETURN
  19890. 2200    CONTINUE
  19891. C RETURN PACKED FORMULA STRING TO EXTRACT UP TO 8 CHARS OF
  19892. C FORMULA.
  19893. C START AT K+6
  19894.     XAC=0.
  19895.     IBGN=K+6
  19896.     IEND=IBGN+20
  19897.     CALL VARSCN(LINE,IBGN,IEND,LSTC,I1,I2,IVLD)
  19898.     IF(IVLD.LE.0)RETURN
  19899. C GET START, LENGTH NOW IN FORMULA...
  19900.     IBGN=LSTC+1
  19901.     IEND=IBGN+20
  19902.     CALL GN(IBGN,IEND,ISTART,LINE)
  19903.     IBGN=INDX(LINE,ICHAR(';'))
  19904. C LOOK FOR ';' CHAR AS START OF 2ND NUMBER
  19905.     IF(IBGN.GT.50.OR.ISTART.LE.0.OR.ISTART.GT.80)RETURN
  19906. C BUMP IBGN PAST THE ; CHAR
  19907.     IBGN=IBGN+1
  19908.     IEND=80
  19909.     CALL GN(IBGN,IEND,ILN,LINE)
  19910.     ILN=MIN0(ILN,8)
  19911.     IF(ILN.LE.0)RETURN
  19912. C READ IN FORMULA INTO WRK ARRAY
  19913. C    IRX=(I2-1)*60+I1
  19914.     CALL REFLEC(I2,I1,IRX)
  19915.     CALL WRKFIL(IRX,WRK2,0)
  19916.     CALL CE2A(WRK2,WRK)
  19917.     KZ=0
  19918.     DO 991 NN=1,ILN
  19919.     K=ICHAR(WRK(ISTART+NN-1))
  19920. C    K=K.AND.127
  19921.     IF(K.EQ.0)KZ=1
  19922.     IF(KZ.EQ.1)K=0
  19923. C STOP THE ENCODE ON SEEING ANY NULLS
  19924.     TMP=K
  19925.     XAC=XAC*128.D0+TMP
  19926. 991    CONTINUE
  19927. C XAC RETURNS WITH ENCODED VALUE.
  19928.     RETURN
  19929. 2300    CONTINUE
  19930. C RETURN PRESENT LOCATION IN THE MATRIX.
  19931.     TAC=PROW
  19932.     UAC=PCOL
  19933.     XAC=(PCOL-1)*MCols+PROW
  19934.     VAC=4*FORMFG+2*RCFGX+RCONE
  19935. C    VAC=(DROW-1)*20+DCOL
  19936. C RESULT IN % IS PHYS SHEET HASHCODE
  19937. C RESULT IN V ACCUMULATOR IS DISPLAY SHEET LOC HASHCODE
  19938. C T AND U ACCUMULATORS GET PHYS COL, ROW OFFSET.
  19939.     WAC=RRWACT
  19940.     YAC=RCLACT
  19941. C W AND Y GET LIMITS CURRENTLY USED
  19942.     RETURN
  19943. 2400    CONTINUE
  19944. C YRMOD
  19945.     RETCD=1
  19946.     IBGN=K+6
  19947.     LEND=IBGN+20
  19948.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  19949.     IF(IVALID.EQ.0)GOTO 9300
  19950.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  19951.     IBGN=LSTCHR+1
  19952.     LEND=IBGN+20
  19953.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  19954.     IF(IVALID.EQ.0)GOTO 9300
  19955.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  19956.     IBGN=LSTCHR+1
  19957.     LEND=IBGN+20
  19958.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1C,ID2C,IVALID)
  19959.     IF(IVALID.EQ.0)GOTO 9300
  19960. C
  19961. C V1, V2, V3 ARE YR, MONTH, DAY FOR RETURN OF JULIAN DATE
  19962. C
  19963.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  19964.     IYR=XVBLS(1,1)
  19965.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  19966.     IMO=XVBLS(1,1)
  19967.     CALL XVBLGT(ID1C,ID2C,XVBLS(1,1))
  19968.     IDA=XVBLS(1,1)
  19969. C RETURN JULIAN DATE FROM Y, M, D GIVEN
  19970.     XAC=JULMDY(IYR,IMO,IDA)
  19971.     RETURN
  19972. 2500    CONTINUE
  19973. C JDATE
  19974.     RETCD=1
  19975.     IBGN=K+6
  19976.     LEND=IBGN+20
  19977. C GET V1 WHICH HAS VARIABLE WITH THE STRING IN IT
  19978.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  19979.     IF(IVALID.EQ.0)GOTO 9300
  19980. C RETURN JULIAN DATE NOW AFTER FETCHING FORMULA.
  19981. C    IRX=(ID2A-1)*60+ID1A
  19982.     CALL REFLEC(ID2A,ID1A,IRX)
  19983.     CALL WRKFIL(IRX,WRK,0)
  19984.     XAC=JULIAN(WRK)
  19985.     RETURN
  19986. 2600    CONTINUE
  19987. C JTOCH
  19988.     RETCD=1
  19989.     IBGN=K+6
  19990.     LEND=IBGN+20
  19991. C V1 = JULIAN DATE
  19992. C V2 IS WHERE TO STORE ASCII DATE STRING AS FORMULA.
  19993.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  19994.     IF(IVALID.EQ.0)GOTO 9300
  19995.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  19996.     IBGN=LSTCHR+1
  19997.     LEND=IBGN+20
  19998.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  19999.     IF(IVALID.EQ.0)GOTO 9300
  20000.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  20001.     IJUL=XVBLS(1,1)
  20002. C    IRX=(ID2B-1)*60+ID1B
  20003.     CALL REFLEC(ID2B,ID1B,IRX)
  20004.     CALL WRKFIL(IRX,WRK,0)
  20005.     DO 2502 N=1,110
  20006. 2502    WRK(N)=0
  20007.     CALL JULASC(IJUL,WRK,IYR,IMO,IDA)
  20008.     CALL WRKFIL(IRX,WRK,1)
  20009. C WRITE THE FORMULA BACK OUT
  20010.     TAC=IMO
  20011.     UAC=IDA
  20012.     VAC=IYR
  20013. C RETURN T,U,V AS M,D,Y ALSO
  20014.     RETURN
  20015. 2700    CONTINUE
  20016. C DATE
  20017.     RETCD=1
  20018.     IBGN=K+5
  20019.     LEND=IBGN+20
  20020.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20021.     IF(IVALID.EQ.0)GOTO 9300
  20022.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20023.     IBGN=LSTCHR+1
  20024.     LEND=IBGN+20
  20025.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20026.     IF(IVALID.EQ.0)GOTO 9300
  20027.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20028.     IBGN=LSTCHR+1
  20029.     LEND=IBGN+20
  20030.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1C,ID2C,IVALID)
  20031.     IF(IVALID.EQ.0)GOTO 9300
  20032.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20033.     IBGN=LSTCHR+1
  20034.     LEND=IBGN+20
  20035.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1D,ID2D,IVALID)
  20036.     IF(IVALID.EQ.0)GOTO 9300
  20037.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  20038.     IYR=XVBLS(1,1)
  20039.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  20040.     IMO=XVBLS(1,1)
  20041.     CALL XVBLGT(ID1C,ID2C,XVBLS(1,1))
  20042.     IDA=XVBLS(1,1)
  20043. C    IRX=(ID2D-1)*60+ID1D
  20044.     CALL REFLEC(ID2D,ID1D,IRX)
  20045.     CALL WRKFIL(IRX,WRK,0)
  20046.     DO 2702 N=1,110
  20047. 2702    WRK(N)=0
  20048.     IJUL=JULMDY(IYR,IMO,IDA)
  20049.     CALL JULASC(IJUL,WRK,IYR,IMO,IDA)
  20050.     CALL WRKFIL(IRX,WRK,1)
  20051.     GOTO 9300
  20052. 2900    CONTINUE
  20053.     RETCD=1
  20054. C WKDYS - GIVE WEEKDAYS (M-F) BETWEEN 2 JULIAN DATES THAT MUST
  20055. C BE IN CELLS.
  20056.     IBGN=K+6
  20057.     LEND=IBGN+20
  20058.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20059.     IF(IVALID.EQ.0)GOTO 9300
  20060.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20061.     IBGN=LSTCHR+1
  20062.     LEND=IBGN+20
  20063.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20064.     IF(IVALID.EQ.0)GOTO 9300
  20065.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  20066.     IYR=XVBLS(1,1)
  20067.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  20068.     IMO=XVBLS(1,1)
  20069. C IYR HOLDS START JULIAN DATE, IMO HOLDS END ONE
  20070.     CALL WKDY(IYR,IMO,IDA)
  20071. C IDA = NUMBER WORK DAYS BETWEEN THE DATES
  20072.     XAC=IDA
  20073. C RETURN DAYS
  20074.     GOTO 9300
  20075. 3000    CONTINUE
  20076.     RETCD=1
  20077. C WKDIN - GIVEN A JULIAN DATE AND A NUMBER WORKDAYS, RETURN THE
  20078. C ENDING JULIAN DATE AFTER THAT NUMBER JULIAN DAYS.
  20079.     IBGN=K+6
  20080.     LEND=IBGN+20
  20081.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20082.     IF(IVALID.EQ.0)GOTO 9300
  20083.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20084.     IBGN=LSTCHR+1
  20085.     LEND=IBGN+20
  20086.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20087.     IF(IVALID.EQ.0)GOTO 9300
  20088.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  20089.     IYR=XVBLS(1,1)
  20090.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  20091.     IMO=XVBLS(1,1)
  20092. C IYR = START DATE, JULIAN. IMO = NUMBER DAYS. RETURN END DATE JULIAN.
  20093.     CALL WRKINT(IYR,IMO,IDA)
  20094. C IDA = RETURN JULIAN DATE
  20095.     XAC=IDA
  20096.     GOTO 9300
  20097. 3100    CONTINUE
  20098. C FFTFW
  20099.     ISI=1
  20100.     GOTO 3210
  20101. 3200    CONTINUE
  20102. C FFTRV
  20103.     ISI=-1
  20104. 3210    CONTINUE
  20105.     RETCD=1
  20106. C MERGED FFT CODE
  20107. C *U FFTFW V1:V2 DOES FFT OF RANGE GIVEN (1-DIM)
  20108. C DITTO FFTRV BUT ONE IS REVERSE AND ONE IS FORWARD FFT
  20109. C REAL*8 FFT ROUTINE USED.
  20110.     IBGN=K+6
  20111.     CALL PMTX2(RETCD,1,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,
  20112.      1  IV,IV,IV,IV,IV,IV,IV,IV)
  20113.     IC=0
  20114.     IR=1
  20115.     IF(IR1T.EQ.IR1B)GOTO 3220
  20116.     IC=1
  20117.     IR=0
  20118. 3220    CONTINUE
  20119.     KK=IABS(IR1T-IR1B)+1
  20120.     KKK=IABS(IC1T-IC1B)+1
  20121.     IV=MAX0(KK,KKK)
  20122. C IV = NO. POINTS.
  20123.     CALL FOUREA(IR1T,IC1T,IC,IR,IV,ISI)
  20124. C THAT'S ALL FOR FFT. REPLACES CELLS IN PLACE...
  20125.     GOTO 9300
  20126. 3300    CONTINUE
  20127. C LINEF
  20128. C *U LINEF VY1:VY2[,VX1:VX2]
  20129. C WHERE X COORDS CAN BE SKIPPED...
  20130.     IBGN=K+6
  20131.     RETCD=1
  20132. C JUST GET 2 MATRICES' VALUES. IF RETCD=3 ON RETURN, 2ND MATRIX MUST HAVE
  20133. C BEEN MISSING SO FLAG IT THAT WAY.
  20134.     CALL PMTX2(RETCD,2,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,IR2T,IC2T,
  20135.      1  IR2B,IC2B,KK,KK,KK,KK)
  20136.     IF(RETCD.NE.1)IR2T=-1
  20137.     RETCD=1
  20138.     KK=IABS(IR1T-IR1B)+1
  20139.     KKK=IABS(IC1T-IC1B)+1
  20140.     IV=MAX0(KK,KKK)
  20141.     KK=0
  20142.     IF(IR1T.EQ.IR1B)GOTO 3320
  20143.     KK=1
  20144. 3320    CONTINUE
  20145.     CALL LINFIT(IR2T,IC2T,KK,IR1T,IC1T,IV,TAC,UAC,XAC,WAC)
  20146. C RETURN A VALUE IN T, B VALUE IN U, AND DEL VALUE IN %.
  20147. C FOR Y = A + BX
  20148. C W AC RETURNS CORRELATION COEFFICIENT.
  20149.     GOTO 9300
  20150. 3400    CONTINUE
  20151. C *U DBxxxx FUNCTIONS PARSED EXTERNALLY
  20152. C (SAVES MUCH SPACE AND EASES MODIFICATION...)
  20153.     RETCD=1
  20154.     CALL DTRFCT(LINE(K+2),RETCD)
  20155.     GOTO 9300
  20156. 3500    CONTINUE
  20157. C *U STxxxx FUNCTIONS
  20158.     RETCD=1
  20159. C K SHOULD BE SUBSCRIPT OF THE 'S' OF "ST" SO SKIP BY THE
  20160. C "ST" PART AND JUST PASS THE REST OF THE FUNCTION NAME AT THE
  20161. C START OF THE STRING...
  20162.     CALL SCIFCT(LINE(K+2),RETCD)
  20163. C HANDLE ALL *U STXXXX FUNCTIONS IN SEPARATE ROUTINE FOR EASE OF
  20164. C MOVING IT AROUND. (MIGHT EVEN GO BACK TO PDP11!)
  20165. C    GOTO 9300
  20166. 9300    RETURN
  20167.     END
  20168. c -h- scifct.fam
  20169. C SCIENTIFIC FUNCTION CALLER
  20170. C This version is a dummy placeholder.
  20171. C The SCIFCT subroutine exists to allow AnalytiCalc to call just
  20172. C about *ANY* Fortran callable routine.
  20173. C   The operation is to use a formula in AnalytiCalc which includes
  20174. c a call of form:
  20175. c  *U STxxxxxx range;range;range;range;range;...;range>outrange;outrange;outrange
  20176. c so that the "xxxxxx" part is the function name to be called.
  20177. c  input ranges are the parts of the sheet for input to the function; these
  20178. c are internally copied to a large array (defined here) which is a normal
  20179. c Fortran array. They are converted to integer*4 as needed if the function
  20180. c being called needs this. Once all conversion is done, the subroutine is
  20181. c called using an argument list built up by this call list. At the end,
  20182. c the output ranges are filled in from the internal Fortran array.
  20183. c   Because Fortran callable subroutines (e.g. those in the SSP) may pass
  20184. c their return arguments in ANY of their arguments, seeing a ; will increment
  20185. c the output range counter.
  20186. c
  20187. c To add more:
  20188. c  * Select desired sizes for work area (must be big enough to hold ALL
  20189. c  arguments used), max number of arguments per function, etc.
  20190. c  * Add new function name and characteristics to tables. Note that the
  20191. c  name, integer/float stuff for all args, which arg is first OUTPUT arg,
  20192. c  and map of output args, all are needed. Don't make first output arg
  20193. c  bigger than the max. number of args.
  20194. c  * Add another call and element in the computed GOTO for each function
  20195. c  desired.
  20196. c  * Build and enjoy.
  20197. c
  20198. c   Internally we need tables of
  20199. c      * Function names (up to 6 characters long per classical Fortran rules)
  20200. c      * Number of arguments needed per function
  20201. c      * Integer/real flags for arguments' data types
  20202. c      * First output argument number (user convenience and less error
  20203. c           prone than having to have a bunch of ;;;;'s to force the
  20204. c           outputrange to come from the right area
  20205. c      * Length of the Fortran array used for each input argument
  20206. c Note: Provision is made for "scratch array" arguments, but is a bit
  20207. c  crude. However, if extra space is needed, user can specify a larger
  20208. c  input area and the larger chunk of scratch space will be present.
  20209. c  Unused argument areas will generally be zeroed on each call.
  20210. c   It is perfectly reasonable to have input-only functions (e.g. plots)
  20211. c   or several subroutines called in sequence for a function.
  20212. c
  20213.     SUBROUTINE SCIFCT(LINE,RETCD)
  20214.     Integer BigSpc
  20215.     Parameter (BigSpc=256)
  20216.     Parameter (MaxArgs=10)
  20217.     Parameter (NFCT=3)
  20218. c NFCT is number of functions included in the list. Update the parameter
  20219. c and the tables together (please!)
  20220.     INTEGER RETCD
  20221.     Character*1 LINE(80)
  20222.     Real*8 ArgAry(BigSpc)
  20223.     INTEGER*4 IARGAR(2,BIGSPC)
  20224.     EQUIVALENCE(IARGAR(1,1),ARGARY(1))
  20225.     Integer*4 ArgCtr,IntPar
  20226.     Integer*4 ArgPtr(MaxArgs)
  20227.     Integer*4 NARGin(NFct)
  20228. c nargin is number input args needed.
  20229.     Integer*4 OutArg(MaxArgs,NFct)
  20230.     Integer*4 OutBgn(NFct)
  20231. c OutArg is 0 for no output, 1 for output area
  20232.     Integer*4 RevStr(MaxArgs,NFct)
  20233. c RevStr will be nonzero to reverse storage of arrays
  20234. c from normal row-first to column-first order.
  20235.     Integer*4 IsReal(MaxArgs,NFCT)
  20236. c
  20237. C Since there are some subs that need dummy argument scratch
  20238. c areas, encode IsReal as follows:
  20239. c  0 = Real
  20240. c  -1 = Integer
  20241. c  +nn = Use argument nn's VALUE (after grabbing it) for
  20242. c        size of area to allocate. Always allocate floats
  20243. c        since they're longer.
  20244. c
  20245. c Note: Due to the way the program allocates scratch array, the
  20246. c  arguments with size info for dummy arrays must be present
  20247. c  ahead of the scratch space arguments.
  20248. c
  20249. C Argument coordinate lists
  20250.     Integer*4 InCord(4,MaxArgs)
  20251.     Integer*4 InType(MaxArgs)
  20252.     Integer*4 OutCor(4,MaxArgs)
  20253.     REAL*8 R8WRK,R8WRK2
  20254.     INTEGER*4 I4WRK,I4WRK2
  20255.     Integer*4 OutTyp(MaxArgs)
  20256. c
  20257.     Character*6 WrkFnm
  20258.     Character*1 WFNm(6)
  20259.     Equivalence(WFNm(1),WrkFnm)
  20260.     Integer*4 IniOut(NFCT)
  20261.     Integer*4 AryPtr
  20262.     Character*6 FName(NFCT)
  20263.     Character*1 FNameB(6,NFCT)
  20264.     Equivalence(Fname(1),FNameB(1,1))
  20265. c allows access of function names by byte, but data stmts to set up
  20266. c as full names...
  20267. c    This example has only 2 functions:
  20268. c  *U STDLLSQ   and
  20269. c  *U STCHISQ
  20270. c        from the Scientific Subroutine Package library...
  20271.     Data FnameB/
  20272.      1  'D','L','L','S','Q',0,
  20273.      2  'C','H','I','S','Q',0,
  20274.      3  'V','E','C','N','O','R' /
  20275.     DATA IsReal/
  20276.      1  0,0,-1,-1,-1,0,5,0,-1,0,
  20277.      2  0,-1,-1,0,-1,-1,2,3,0,0,
  20278.      3  0,-1,0,0,0,0,0,0,0,0  /
  20279.     DATA OutBgn/
  20280.      1  6,4,3 /
  20281.     DATA OutArg/
  20282.      1  0,0,0,0,0,1,0,0,1,1,
  20283.      2  0,0,0,1,1,1,0,0,0,0,
  20284.      3  0,0,1,0,0,0,0,0,0,0 /
  20285. c Note OutArg is just which output arguments are really
  20286. c output data. 1 means they are, 0 means they're not.
  20287. c
  20288. C NARGIN is min number input arguments that must be present.
  20289.     Data NARGin/10,8,3/
  20290.     Data RevStr/
  20291.      1  0,0,0,0,0,0,0,0,0,0,
  20292.      2  0,0,0,0,0,0,0,0,0,0,
  20293.      3  0,0,0,0,0,0,0,0,0,0/
  20294. C
  20295. C FIRST, before we spend a lot of effort grabbing arguments, make
  20296. c  sure we know about the function to be called. If we don't, just
  20297. c  return an error.
  20298.     KK=0
  20299.     DO 101 N=1,NFCT
  20300.     DO 110 NN=1,6
  20301.     IF(Ichar(FNAMEB(NN,N)).LE.0)GOTO 110
  20302.     IF(LINE(NN).NE.FNAMEB(NN,N)) GOTO 112
  20303. 110    CONTINUE
  20304. C WE FELL THRU AND FOUND THE NAME. SAVE ITS' INDEX.
  20305.     KK=N
  20306. 112    CONTINUE
  20307. 101    CONTINUE
  20308.     IF(KK.GT.0)GOTO 115
  20309. 114    RETCD=3
  20310.     RETURN
  20311. 115    CONTINUE
  20312.     NFUNCT=KK
  20313. c A little setup...
  20314.     ArgCtr=1
  20315.     IntPar=1
  20316. c integer "parity", used to pack integer args in work array
  20317.     Aryptr=1
  20318.     Do 1 n=1,MaxArgs
  20319.     Argptr(n)=1
  20320.     Do 11 nn=1,4
  20321.     InCord(nn,n)=0
  20322.     OutCor(nn,n)=0
  20323. 11    Continue
  20324. 1    CONTINUE
  20325.     DO 2 N=1,BigSpc
  20326.     ArgAry(N)=0.0D0
  20327. 2    Continue
  20328. C arrange for all uninitialized numbers to contain zeroes
  20329.     RETCD=1
  20330. C HANDLE *U STXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
  20331. C STARTS AFTER THE "ST" SO WE CAN DECODE IT.
  20332. c if we can't get the function, return RETCD=3...
  20333. c
  20334. c Now grab the arguments and store them in InCord, Intype, OutCor, OutTyp
  20335.     K=INDXQ(LINE,32)
  20336. C FIND STUFF AFTER SPACE
  20337.     K=K+1
  20338.     NArg=1
  20339.     IBGN=1
  20340. 100    Continue
  20341.     LEND=IBGN+20
  20342. C GET LOC OF MATRIX A (MUST BE SQUARE)
  20343.     ID1B=0
  20344.     ID2B=0
  20345.     ID1A=0
  20346.     ID2A=0
  20347.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20348.     IF(IVALID.EQ.0)GOTO 300
  20349.     IF(LINE(K+LSTCHR-1).NE.':')GOTO 1000
  20350.     IBGN=LSTCHR+1
  20351.     LEND=IBGN+20
  20352.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20353.     IF(IVALID.EQ.0)GOTO 300
  20354. 1000    CONTINUE
  20355. C GMTX GETS ARGS FOR ONE RANGE
  20356.     InCord(1,NArg)=ID1A
  20357.     InCord(2,NArg)=ID2A
  20358.     INCord(3,NARG)=ID1B
  20359.     INCORD(4,NARG)=ID2B
  20360.     IBGN=LSTCHR+1
  20361.     NARG=NARG+1
  20362.     IF(LINE(K+LSTCHR-1).EQ.';')GOTO 100
  20363. C
  20364. 300    CONTINUE
  20365. C NOW HAVE ALL ARGS FOR INPUT COLLECTED
  20366.     INARGS=NARG
  20367.     If(INargs.lt.NARGin(NFunct)) GOTO 114
  20368. c Flag error if not enough input args presented.
  20369.     K=INDXQ(LINE,62)
  20370. C FIND STUFF AFTER > CHARACTER
  20371.     IF(K.EQ.0.OR.K.GT.70)GOTO 500
  20372. C MUST HAVE A > OR no outputs are present.
  20373. C This is perfectly legal; outputs like graphs or auxiliary
  20374. C files (unknown to rest of program) are possible too.
  20375.     K=K+1
  20376.     NArg=1
  20377.     IBGN=1
  20378. 400    Continue
  20379.     LEND=IBGN+20
  20380. C GET LOC OF MATRIX A (MUST BE SQUARE)
  20381.     ID1B=0
  20382.     ID2B=0
  20383.     ID1A=0
  20384.     ID2A=0
  20385. C TEST FOR NULL ARGUMENT (;; PAIR)
  20386.     IF(LINE(K+IBGN-1).EQ.';')GOTO 450
  20387.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20388.     IF(IVALID.EQ.0)GOTO 500
  20389.     IF(LINE(K+LSTCHR-1).NE.':')GOTO 1500
  20390.     IBGN=LSTCHR+1
  20391.     LEND=IBGN+20
  20392.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20393.     IF(IVALID.EQ.0)GOTO 500
  20394. 1500    CONTINUE
  20395.     IBGN=LSTCHR+1
  20396.     GOTO 455
  20397. 450    CONTINUE
  20398.     IBGN=IBGN+1
  20399.     LSTCHR=IBGN
  20400. C PASS ;
  20401. 455    CONTINUE
  20402. C GMTX GETS ARGS FOR ONE RANGE
  20403.     OUTCor(1,NArg)=ID1A
  20404.     OUTCor(2,NArg)=ID2A
  20405.     OUTCor(3,NARG)=ID1B
  20406.     OUTCor(4,NARG)=ID2B
  20407.     NARG=NARG+1
  20408.     IF(LINE(K+LSTCHR-1).EQ.';')GOTO 400
  20409. C    GOTO 500
  20410. C
  20411. 500    CONTINUE
  20412. C NOW HAVE OUTPUT ARGUMENT LIST COLLECTED
  20413. C BEGIN COLLECTING DATA
  20414.     NARG=1
  20415.     IntPar=1
  20416. 2000    CONTINUE
  20417.     IACNTR=ARGCTR
  20418. C  GET INPUT DATA INTO OUR BIG ARRAY
  20419.     IF(INCORD(1,NARG).LE.0)GOTO 3000
  20420.     ARGPTR(NARG)=ARGCTR
  20421.     IF(INCORD(3,NARG).NE.0)GOTO 2011
  20422. C SINGLE ARGUMENT; GRAB IT
  20423.     nn=incord(1,narg)
  20424.     mm=incord(2,narg)
  20425.     call typget(nn,mm,itype)
  20426.     If(Itype.ne.4) then
  20427.       CALL XVBLGT(NN,MM,R8WRK)
  20428.     Else
  20429.       Call JVBLGT(NN,MM,I4wrk)
  20430.       R8WRK=I4WRK
  20431.     End If
  20432. c    CALL XVBLGT(INCORD(1,NARG),INCORD(2,NARG),R8WRK)
  20433.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  20434.       INTPAR=1
  20435.       I4WRK=R8WRK
  20436.       IARGAR(IntPar,ARGCTR)=I4WRK
  20437.     ELSE
  20438.       If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
  20439.       IntPar=1
  20440. C if we last packed the second word of an integer, bump to next
  20441.       ARGARY(ARGCTR)=R8WRK
  20442.     END IF
  20443.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  20444.     NARG=NARG+1
  20445.     GOTO 2000
  20446. 2011    CONTINUE
  20447. C 2-D AREA
  20448.     IntPar=1
  20449.     DO 2020 LNN=INCORD(1,NARG),INCORD(3,NARG)
  20450.     DO 2020 LMM=INCORD(2,NARG),INCORD(4,NARG)
  20451.     NN=LNN
  20452.     IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
  20453.     MM=LMM
  20454.     IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
  20455.     call typget(nn,mm,itype)
  20456.     If(Itype.ne.4) then
  20457.       CALL XVBLGT(NN,MM,R8WRK)
  20458.     Else
  20459.       Call JVBLGT(NN,MM,I4wrk)
  20460.       R8WRK=I4WRK
  20461.     End If
  20462.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  20463.       I4WRK=R8WRK
  20464.       IARGAR(IntPar,ARGCTR)=I4WRK
  20465.       IntPar=3-IntPar
  20466. c if IntPar is 1 make it 2; if it's 2, make it 1
  20467.     ELSE
  20468.       If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
  20469.       IntPar=1
  20470. C if we last packed the second word of an integer, bump to next
  20471.       ARGARY(ARGCTR)=R8WRK
  20472.     END IF
  20473.     If(IntPar.eq.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
  20474. 2020    CONTINUE
  20475.     NARG=NARG+1
  20476.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  20477.     IntPar=1
  20478. C
  20479. C FIX UP DUMMY ARGUMENTS
  20480. C
  20481.     IF(ISREAL(NARG,NFUNCT).GT.0.AND.ISREAL(NARG,NFUNCT)
  20482.      1  .LE.MAXARGS) THEN
  20483. c If user allocated more space than the dummy calc, use bigger
  20484. c allocation. However, add a little more and check for array
  20485. c overflow.
  20486.       ARGCTR=MAX0(ARGCTR,IACNTR+IARGAR(1,ISREAL(NARG,NFUNCT)))
  20487.       ARGCTR=ARGCTR+30
  20488.       ARGCTR=MIN0(ARGCTR+1,BigSpc)
  20489. C ADD A LITTLE FOR GOOD LUCK
  20490.     END IF
  20491.     GOTO 2000
  20492. 3000    CONTINUE
  20493. C NOW SHOULD BE READY TO CALL THIS STUFF...
  20494. C GENERATE CALLS LIKE THE TEMPLATES BELOW. NO NEED TO MODIFY
  20495. C THE FUNCTIONS, BUT WE DO NEED TO MESS WITH THIS STUFF BECAUSE
  20496. C I DON'T KNOW OFFHAND HOW TO DO A DYNAMIC CALLING LIST IN FORTRAN
  20497. C THAT'LL WORK ON STACK IMPLEMENTATIONS.
  20498. c
  20499. c Add more numbers to the list here to get more function calls.
  20500. c
  20501.     GOTO (4001,4002,4003),NFUNCT
  20502.     RETCD=3
  20503.     RETURN
  20504. c *************** BEGINNING OF CALLS ****************
  20505. 4001    CONTINUE
  20506. C DLLSQ FUNCTION.... 10 ARGS
  20507.     CALL DLLSQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
  20508.      1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
  20509.      2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)),
  20510.      3  ARGARY(ARGPTR(9)),ARGARY(ARGPTR(10)))
  20511.     GOTO 5000
  20512. 4002    CONTINUE
  20513. C CHISQ FUNCTION.... 8 ARGS
  20514.     CALL CHISQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
  20515.      1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
  20516.      2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)))
  20517.     GOTO 5000
  20518. 4003    CONTINUE
  20519. C Vector Norm function
  20520.     CALL VECNOR(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
  20521.      1  ARGARY(ARGPTR(3)))
  20522. C Use this for debugging too...
  20523. c
  20524. c insert more function calls here... they all look alike except for
  20525. c function name.
  20526. c
  20527. c  It's also completely permissible to call several Fortran subroutines
  20528. c  in sequence here if it makes sense; it's up to the user. This code
  20529. c  just gives a way to call unmodified Fortran callable code and have
  20530. c  it make sense in the AnalytiCalc context. ANY Fortran callable code
  20531. c  is OK.
  20532. c
  20533. c *****************end of calls *****************
  20534. c
  20535. 5000    CONTINUE
  20536. C NOW GET ARGUMENTS BACK TO DUMP TO SHEET
  20537.     KARG=0
  20538.     DO 5100 NARG=OUTBGN(NFUNCT),MAXARGS
  20539.     KARG=KARG+1
  20540.     IF(OUTARG(NARG,NFUNCT).LE.0)GOTO 5100
  20541.     IF(OUTCOR(1,KARG).EQ.0)GOTO 5100
  20542. C +++
  20543.     ARGCTR=ARGPTR(NARG)
  20544.     IF(OUTCOR(3,KARG).NE.0)GOTO 6014
  20545. C SINGLE ARGUMENT; GRAB IT
  20546.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  20547.       I4WRK=IARGAR(1,ARGCTR)
  20548.       R8WRK=I4WRK
  20549.     ELSE
  20550.       R8WRK=ARGARY(ARGCTR)
  20551.     END IF
  20552.     nn=outcor(1,karg)
  20553.     mm=outcor(2,karg)
  20554.     Call typget(nn,mm,itype)
  20555.     If (Itype.ne.4) then
  20556.       CALL XVBLST(NN,MM,R8WRK)
  20557.     Else
  20558.       I4WRK=R8WRK
  20559.       CALL JVBLST(nn,mm,I4WRK)
  20560.     End If
  20561.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  20562.     GOTO 5100
  20563. 6014    CONTINUE
  20564. C 2-D AREA
  20565.     DO 6020 LNN=OUTCOR(1,KARG),OUTCOR(3,KARG)
  20566.     DO 6020 LMM=OUTCOR(2,KARG),OUTCOR(4,KARG)
  20567.     NN=LNN
  20568.     IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
  20569.     MM=LMM
  20570.     IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
  20571.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  20572.       I4WRK=IARGAR(1,ARGCTR)
  20573.       R8WRK=I4WRK
  20574.     ELSE
  20575.       R8WRK=ARGARY(ARGCTR)
  20576.     END IF
  20577.     Call typget(nn,mm,itype)
  20578.     If (Itype.ne.4) then
  20579.       CALL XVBLST(NN,MM,R8WRK)
  20580.     Else
  20581.       I4WRK=R8WRK
  20582.       CALL JVBLST(nn,mm,I4WRK)
  20583.     End If
  20584. c    CALL XVBLST(NN,MM,R8WRK)
  20585.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  20586. 6020    CONTINUE
  20587. C +++
  20588. 5100    CONTINUE
  20589. C AT LAST, DONE
  20590.     RETURN
  20591.     END
  20592.     Subroutine VecNor(InRng,NVEC,Val)
  20593. C test subroutine
  20594. c Computes norm of input range, where NVEC is number of
  20595. c elements in the INRNG array.
  20596.     REAL*8 InRng
  20597.     Dimension InRng(1)
  20598.     Integer*4 NVEC
  20599.     Real*8 Val,X
  20600. C    VAL=0.0d0
  20601.     If(NVEC.LE.0)val=-1.0
  20602.     If(NVEC.LE.0)return
  20603. c return -1 if bad dimensions.
  20604.     X=0.0D0
  20605.     Do 1 n=1,nvec
  20606.     x=x+InRng(n)*InRng(n)
  20607. 1    Continue
  20608.     x=dsqrt(x)
  20609.     Val=X
  20610.     Return
  20611.     End
  20612. c -h- JunkDum.for
  20613. c completely dummy versions of dllsq and chisq
  20614. C REMOVE these if you want to use the real ones (from
  20615. c the SSP library)
  20616.     Subroutine DLLSQ(A,B,C,D,E,F,G,H,I,J)
  20617.     RETURN
  20618.     END
  20619.     SUBROUTINE CHISQ(A,B,C,D,E,F,G,H)
  20620.     RETURN
  20621.     END
  20622. c -h- uvtgen.for    Fri Aug 22 13:36:30 1986    
  20623. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  20624. C ALL RIGHTS RESERVED
  20625. C
  20626. C    VT100 VIDEO DISPLAY COMMAND PROGRAM. CALLING SEQUENCE IS
  20627. C    CALL UVT100(CMD,N1,N2THE MANDS IN
  20628. C    THE PARAMETER LIST BELOW, AND N1 AND N2 ARE OPTIONAL PARAMETERS
  20629. C    DEPENDING UPON CMD. SEE THE UVT100 USER'S MANUAL FOR MORE DETAILS.
  20630. C
  20631. C
  20632. C BLACK AND WHITE SCREEN MODULE FOR ANSI TERMINALS
  20633. C ALSO COLOR SCREEN MODULE.
  20634. C COMMANDS 20 AND 21 SWITCH: 20 SETS B+W, 21 SETS COLOR MODE
  20635. C
  20636. C THIS VERSION MODIFIED FOR USE WITH PORTACALC.
  20637. C  ENTRIES NOT USED ARE DELETED, AND ALSO CODE ADDED TO SUPPORT COLOR
  20638. C  CRT'S THAT ARE BASICALLY VT100-LIKE WITH EXTENSIONS, OR VT100'S OR
  20639. C  EMULATORS WITH AVO OPTION.
  20640. C
  20641. C  OPERATION:
  20642. C    ON B+W VT100'S (WITH ADVANCED VIDEO), THE SET GRAPHICS CODES
  20643. C WILL BE USED AS FOLLOWS:
  20644. C  ALTERNATE ROWS WILL BE DISPLAYED IN BOLD
  20645. C  (ROW 3 TO 22 ONLY HOWEVER; THE REST IS NOT MATH AREA)
  20646. C COMMAND AND DISPLAY ROWS (23 AND 24 NORMALLY) WILL BE BOLDED ALWAYS.
  20647. C
  20648. C  IN COLOR MODE:
  20649. C    ON ED, SET BACKGROUND COLOR TO DARK BLUE
  20650. C    ALTERNATE ROWS WILL BE SET TO YELLOW OR GREEN
  20651. C  COLUMN LABEL ROW, LABEL ROW, AND ROW LABELS, AND COMMAND PROMPTS,
  20652. C  IN A DIFFERENT COLOR FOR EACH. DETERMINED AND SET AT TIME OF
  20653. C  CALL TO CURSOR POSITION.
  20654. C
  20655. C    AUTHOR:    GLENN EVERHART
  20656. C
  20657.       SUBROUTINE UVT100 ( CMD, N1, N2 )
  20658.       IMPLICIT INTEGER ( A - Z )
  20659.       DIMENSION PRL ( 6 )
  20660. C NOTE WE DECLARE THESE VARIABLES USED IN PORTACALC. THEY ARE ALL IN
  20661. C COMMONS, SO WE ADD NOTHING TO LENGTH OF THIS PROGRAM BY ADDING THEM.
  20662.     CHARACTER*1 FVLD
  20663.     DIMENSION FVLD(1,1)
  20664.     COMMON /FVLDC/FVLD
  20665. C ***<<<< RDD COMMON START >>>***
  20666.     InTeGer*4 RRWACT,RCLACT
  20667. C    COMMON/RCLACT/RRWACT,RCLACT
  20668.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  20669.      1  IDOL7,IDOL8
  20670. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  20671. C     1  IDOL7,IDOL8
  20672.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  20673. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  20674.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  20675. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  20676. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  20677. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  20678.     InTeGer*4 KLVL
  20679. C    COMMON/KLVL/KLVL
  20680.     InTeGer*4 IOLVL,IGOLD
  20681. C    COMMON/IOLVL/IOLVL
  20682. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  20683. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  20684.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  20685.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  20686.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  20687.      3  k3dfg,kcdelt,krdelt,kpag
  20688. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  20689. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  20690. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  20691. C ***<<< RDD COMMON END >>>***
  20692. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  20693. CCC    InTeGer*4 LLCMD,LLDSP
  20694. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  20695.     InTeGer*4 TYPE(1,1),VLEN(9)
  20696.     REAL*8 XVBLS(1,1)
  20697.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  20698.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  20699.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  20700. C ICPOS COMMON HAS PHYS COORDS BEING DISPLAYED. MUST QUERY FVLD TO
  20701. C SEE WHETHER TO INTENSIFY THE FIELD FOR NEGATIVE...
  20702. C ***<<< XVXTCD COMMON START >>>***
  20703.     CHARACTER*1 OARRY(100)
  20704.     InTeGer*4 OSWIT,OCNTR
  20705. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  20706. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  20707.     InTeGer*4 IC1POS,IC2POS,MODFLG
  20708. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  20709.        InTeGer*4 XTCFG,IPSET,XTNCNT
  20710.        CHARACTER*1 XTNCMD(80)
  20711. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  20712. C VARY FLAG ITERATION COUNT
  20713.     INTEGER KALKIT
  20714. C    COMMON/VARYIT/KALKIT
  20715.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  20716.     InTeGer*4 RCMODE,IRCE1,IRCE2
  20717. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  20718. C     1  IRCE2
  20719. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  20720. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  20721. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  20722. C RCFGX ON.
  20723. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  20724. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  20725. C  AND VM INHIBITS. (SETS TO 1).
  20726.     INTEGER*4 FH
  20727. C FILE HANDLE FOR CONSOLE I/O (RAW)
  20728. C    COMMON/CONSFH/FH
  20729.     CHARACTER*1 ARGSTR(52,4)
  20730. C    COMMON/ARGSTR/ARGSTR
  20731.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  20732.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  20733.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  20734.      3  IRCE2,FH,ARGSTR
  20735. C ***<<< XVXTCD COMMON END >>>***
  20736. CCC    InTeGer*4 IC1POS,IC2POS,MODFLG
  20737. CCC    COMMON/ICPOS/IC1POS,IC2POS,MODFLG
  20738. C CONTROLS TO SET VARIOUS VISUAL ATTRIBUTES
  20739. C NORMAL, BOLD
  20740.     InTeGer*4 N1SV,N2SV,N222
  20741.     CHARACTER*1 CLSV(8)
  20742. c        CHARACTER*1 ULIT(8)
  20743. c    CHARACTER*1 NORMIT(4)
  20744.     CHARACTER*1 OUTBUF(16)
  20745. C    CHARACTER*1 NORMIT(4),BOLDIT(8),OUTBUF(16),BOLDUL(10)
  20746.     CHARACTER*2 OBF3
  20747.     CHARACTER*3 OBF6
  20748.     EQUIVALENCE (OBF3,OUTBUF(3)),(OBF6,OUTBUF(6))
  20749.     InTeGer*4 COLSW
  20750. C COLOR SCHEME CODED DATA ABOVE...
  20751.     DATA N222/0/
  20752.     DATA COLSW/0/
  20753. C LEAVE IN THE BOLDING FOR NEGATIVE NUMBERS
  20754. c    DATA NORMIT/'^[','[','0','m'/
  20755. C SET ATTRIBUTE 4 (UNDERLINE) RATHER THAN 1 (BOLD) FOR ALTERNATE LINES.
  20756. c fill in initial escape character (27 decimal)
  20757.       OUTBUF ( 1 ) = Char(27)
  20758.       DO 20000  I = 2, 16
  20759. c fill in spaces in out buffer (32 decimal = ascii space)
  20760.       OUTBUF ( I ) = Char(32)
  20761. 20000 CONTINUE
  20762. 20001 CONTINUE
  20763. C CMD 20 TURNS COLOR ON, 21 TURNS IT OFF.
  20764.       IF ( CMD .NE. 1) GOTO 20002
  20765. C CURSOR POSITION.
  20766. C SHIP OUT APPROPRIATE CHARACTERISTICS.
  20767.  
  20768. 7701    CONTINUE
  20769. 1754    CONTINUE
  20770. 1500    CONTINUE
  20771. 7711    CONTINUE
  20772.       OUTBUF ( 2 ) = '['
  20773.       IF (.NOT.( N1 .GT. 0 . AND . N1 .LE. (LLDSP+1) )) GOTO 20004
  20774.        WRITE(OBF3(1:2),10,ERR=20004)N1
  20775. C      ENCODE ( 2, 10, OUTBUF ( 3 ) ) N1
  20776. 20004 CONTINUE
  20777.       OUTBUF ( 5 ) = ';'
  20778. C ALLOW WIDE DISPLAYS FOR MACHINES LIKE THE RAINBOW...
  20779. C NOTE: USES MSDOS FORTRAN V3.2 FEATURE OF  I3.3 FORMAT...
  20780.       IF (.NOT.( N2 .GT. 0 . AND . N2 .LT. 233)) GOTO 20006
  20781.        WRITE(OBF6(1:3),105,ERR=20006)N2
  20782. C      ENCODE ( 3, 105, OUTBUF ( 6 ) ) N2
  20783. C FIX THE ABOVE FOR 132 COLUMN MAX ON RAINBOW. NO NEED TO LIMIT TO 80 COLS ON
  20784. C MACHINES THAT CAN HANDLE 132 OR MORE, BUT IBM MAY GOOF UP UNLESS LIMIT IS
  20785. C IN EFFECT. (LOSE LOSE)
  20786.     IF(OUTBUF(4).EQ.' ')OUTBUF(4)='0'
  20787.     IF(OUTBUF(7).EQ.' ')OUTBUF(7)='0'
  20788.     IF(OUTBUF(3).EQ.' ')OUTBUF(3)='0'
  20789.     IF(OUTBUF(6).EQ.' ')OUTBUF(6)='0'
  20790. 20006 CONTINUE
  20791.       OUTBUF ( 9 ) = 'H'
  20792.       LEN = 9
  20793.       GOTO 20003
  20794. 20002 CONTINUE
  20795.       IF ( CMD .NE. 11 ) GOTO 20036
  20796. C ERASE DISPLAY
  20797. C ALWSAYS ERASE WHOLE DISPLAY HERE.
  20798.     OUTBUF(1)=27
  20799.     call swrt(outbuf,1)
  20800.     call swrt('[0;0H',5)
  20801.     call swrt(outbuf,1)
  20802.     CALL SWRT('[2J',3)
  20803.     RETURN
  20804. 20036 CONTINUE
  20805.       IF ( CMD .NE. 12 ) GOTO 20042
  20806. C ERASE LINE
  20807. C EITHER ERASE WHOLE LINE BY DOING CR FIRST, OR JUST END OF LINE
  20808. C IF HE USED CODE 2.
  20809. C CAN'T HANDLE ERASING START ONLY, BUT ANALYTICALC NEVER TRIES THIS.
  20810. C DO C.R. FIRST IF CALLED FOR
  20811. 22001    CONTINUE
  20812.     if(n1.EQ.2)goto 20044
  20813. cc just emit line
  20814.     outbuf(1)=27
  20815.     outbuf(2)='['
  20816.     outbuf(3)='K'
  20817.     len=3
  20818.     goto 20003
  20819. C ERASE ALL BY RETURN, ERASE SEQ
  20820. 20044    outbuf(1)=13
  20821.     outbuf(2)=27
  20822.     outbuf(3)='['
  20823.     outbuf(4)='K'
  20824.       LEN = 4
  20825.       GOTO 20003
  20826. 20042 CONTINUE
  20827.       IF ( CMD .NE. 13 ) GOTO 20048
  20828. C SET GRAPHICS RENDITION (7=REVERSE VIDEO, 0=NORMAL,4=UNDERSCORE,1=BOLD
  20829. C  5=BLINK) (PORTACALC CALLS WITH 0 OR 7 (VT100 W/O AVO))
  20830. C    IF(MODFLG.NE.1)GOTO 22002
  20831. 22002    CONTINUE
  20832.     OUTBUF(1)=27
  20833.     call swrt(outbuf,1)
  20834.     IF(N1.EQ.7)CALL SWRT('[7m',3)
  20835.     if(n1.ne.7)call swrt('[0m',3)
  20836.     return
  20837. 20048 CONTINUE
  20838. c      IF (.NOT.( CMD .EQ. 15 )) GOTO 20054
  20839. C SCS. IGNORE THIS ... NEVER REALLY USED.
  20840.     RETURN
  20841. 20003 CONTINUE
  20842. 20073 CONTINUE
  20843. C USE A FORTRAN WRITE SO THIS WILL WORK ON VAX OR PDP11 (OR WHATEVER...)
  20844. C  UNIT 6 MUST BE THE TERMINAL...
  20845.     CALL SWRT(OUTBUF,LEN)
  20846. 10    FORMAT ( I2 )
  20847. 105    FORMAT(I3.3)
  20848.       RETURN
  20849.       END
  20850. c -h- varout.for    Fri Aug 22 13:37:17 1986    
  20851.     SUBROUTINE VAROUT (INDXX,IX2)
  20852. C COPYRIGHT (C) 1983 GLENN EVERHART
  20853. C ALL RIGHTS RESERVED
  20854. C 60=MAX REAL ROWS
  20855. C 301=MAX REAL COLS
  20856. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  20857. C VBLS AND TYPE DIMENSIONED 60,301
  20858. C
  20859. C **************************************************
  20860. C *                                                *
  20861. C *       SUBROUTINE   VAROUT                      *
  20862. C *                                                *
  20863. C **************************************************
  20864. C
  20865. C
  20866. C
  20867. C  OUTPUTS THE VALUE OF THE VARIABLE POINTED TO BY INDXX.
  20868. c modified version - multiple precision calls diked out - gce
  20869. C
  20870. C  ASCII     A1 FORMAT UNLESS THE ASCII VALUE IS LESS THAN 32.
  20871. C            IN SUCH CASES, 32 IS ADDED TO THE VALUE AND THE
  20872. C            CHARACTER IS OUTPUT  SO THAT IT IS PRECEDED BY THE
  20873. C            CHARACTER '^'.
  20874. C
  20875. C  DECIMAL   A COMPUTED F FORMAT.
  20876. C
  20877. C  HEXADECIMAL  LEADING ZEROES, "BASE 16" QUE.
  20878. C
  20879. C  INTEGER   I12 FORMAT
  20880. C
  20881. C  OCTAL     LEADING ZEROES, "BASE 8" QUE
  20882. C
  20883. C  REAL      D25.18 FORMAT
  20884. C
  20885. C
  20886. C  VAROUT CALLS
  20887. C
  20888. C ERRMSG   PRINTS OUT ERROR MESSAGES
  20889. C MOUT     OUTPUTS MULTIPLE PRECISION NUMBERS
  20890. C
  20891. C
  20892. C
  20893. C
  20894. C
  20895. C VAROUT IS CALLED BY CALC AND POSTVL
  20896. C
  20897. C
  20898. C
  20899. C  VARIABLE   USE
  20900. C
  20901. C  DEC        HOLDS NUMBER OF DIGITS TO THE RIGHT OF THE
  20902. C             DECIMAL POINT IN F FORMAT SPECIFICATION.
  20903. C  DFORM(11)  HOLDS FORMAT SPECIFICATION FOR F FORMAT
  20904. C             (OUTPUTTING VALUE OF VARIABLES WITH DECIMAL DATA TYPE).
  20905. C  DIGITS     HOLDS THE ASCII CHARACTERS FOR VARIOUS DIGITS.
  20906. C  EIGHT(8)   USED TO PICK OFF REAL*8 'S FROM VBLS.
  20907. C             ALSO HOLDS HEXADECIMAL DIGITS IF # IS DATA TYPE HEX.
  20908. C  FOUR(4)    USED TO PICK OFF INTEGER*4'S FROM VBLS.
  20909. C  I,K        HOLDS TEMPORARY VALUES.
  20910. C  I1         HOLDS THE FIRST DIGIT IN CREATING AN F FORMAT SPECIFICATION.
  20911. C  I2         HOLDS THE SECOND DIGIT IN CREATING AN F FORMAT SPEC.
  20912. C  INDXX      POINTS TO VARIABLE BEING OUTPUT.
  20913. C  IPT        POINTER FOR DFORM.
  20914. C  ISV        POINTER FOR VECTOR SIGN(2).
  20915. C  ITWO       TWO IS USED TO PICK OFF A BYTE OF THE INTEGER
  20916. C  TWO(2)     REPRESENTATION. THEN ITWO IS USED AS
  20917. C             THE VALUE. THIS IS DONE BECAUSE OTHERWISE
  20918. C             SOME COMPILERS WOULD FORCE A SIGN EXTEND.
  20919. C  L          TEMPORARY VALUES. POINTER FOR EIGHT(8).
  20920. C  LEVIN(11)  HOLDS PRINTABLE ASCII CHARACTERS WHICH REPRESENT
  20921. C             AN OCTAL NUMBER. EQUIVALENCED WITH EIGHT(8).
  20922. C  M1         HOLDS HIGH ORDER HEXADECIMAL DIGIT.
  20923. C  M2         HOLDS LOW ORDER HEXADECIMAL DIGIT.
  20924. C  MAG        HOLDS THE MAGNITUDE OF A REAL*8 NUMBER
  20925. C  P10        REAL*8 THAT HOLDS POWERS OF 10. (DECIMAL)
  20926. C  RETCD      HOLDS RETURN CODE FROM CALL TO MOUT.
  20927. C  RPAR       ')'
  20928. C  SIGN(2)    HOLDS PRINTABLE ASCII CHARACTERS FOR OUTPUTTING THE
  20929. C             SIGN OF A NUMBER.
  20930. C  STAR1      HOLDS A SINGLE CHARACTER.
  20931. C  VBLS(100,27)  HOLDS VALUE FOR EACH VARIABLE.
  20932. C  WIDTH      WIDTH SPECIFICATION FOR F FORMAT.
  20933. C
  20934. C
  20935. C
  20936. C    SUBROUTINE VAROUT (INDXX,IX2)
  20937. C
  20938. C NOTE THAT VAROUT IS USED TO DUMP ONLY VALUES FROM AVBLS, NOT
  20939. C VBLS (IX2=1 ALWAYS AT CALLS). THUS DON'T BOTHER TO PICK UP
  20940. C ANY FURTHER INFO FROM VBLS HERE.
  20941.     REAL*8 REAL,MAG,P10
  20942. C
  20943.     INTEGER*4 INT,L,K
  20944. C
  20945.     InTeGer*4 ITWO,INDXX
  20946.     InTeGer*4 TYPE(1,1),WIDTH,DEC,VLEN(9),RETCD
  20947. C
  20948.     CHARACTER*1 AVBLS(20,27),STAR1,EIGHT(8),FOUR(4)
  20949.     CHARACTER*1 VBLS(8,1,1)
  20950.     CHARACTER*1 TWO(2)
  20951.     CHARACTER*1 DFORM(11),DIGITS(16,3),LEVIN(11)
  20952.     CHARACTER*11 DFORM1
  20953.     EQUIVALENCE(DFORM1(1:1),DFORM(1))
  20954.     CHARACTER*1 SIGN(2)
  20955.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  20956. C ***<<< XVXTCD COMMON START >>>***
  20957.     CHARACTER*1 OARRY(100)
  20958.     InTeGer*4 OSWIT,OCNTR
  20959. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  20960. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  20961.     InTeGer*4 IPS1,IPS2,MODFLG
  20962. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  20963.        InTeGer*4 XTCFG,IPSET,XTNCNT
  20964.        CHARACTER*1 XTNCMD(80)
  20965. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  20966. C VARY FLAG ITERATION COUNT
  20967.     INTEGER KALKIT
  20968. C    COMMON/VARYIT/KALKIT
  20969.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  20970.     InTeGer*4 RCMODE,IRCE1,IRCE2
  20971. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  20972. C     1  IRCE2
  20973. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  20974. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  20975. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  20976. C RCFGX ON.
  20977. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  20978. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  20979. C  AND VM INHIBITS. (SETS TO 1).
  20980.     INTEGER*4 FH
  20981. C FILE HANDLE FOR CONSOLE I/O (RAW)
  20982. C    COMMON/CONSFH/FH
  20983.     CHARACTER*1 ARGSTR(52,4)
  20984. C    COMMON/ARGSTR/ARGSTR
  20985.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  20986.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  20987.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  20988.      3  IRCE2,FH,ARGSTR
  20989. C ***<<< XVXTCD COMMON END >>>***
  20990. CCC    InTeGer*4 OSWIT,OCNTR
  20991. C NOTE: OSWIT NONZERO MEANS OUTPUT TO OARRY.
  20992. C OSWIT=2 MEANS NO ZEROING OF OARRY; NOTHING MUCH COMES OUT.
  20993. CCC    CHARACTER*1 OARRY(100)
  20994. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  20995. C
  20996.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  20997.     COMMON /DIGV/ DIGITS
  20998.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  20999.     Character*127 cwrk
  21000.     Character*2 crlf
  21001. C
  21002.     EQUIVALENCE (TWO,ITWO)
  21003.     EQUIVALENCE (REAL,EIGHT),(INT,FOUR),(EIGHT,LEVIN)
  21004. C
  21005.     DATA SIGN/' ','-'/
  21006.     DATA DFORM /'(', '1', 'X', ',', 'F', ' ', ' ', '.', ' ', ' ',
  21007.      ;  ')'/
  21008.     DATA ITWO/0/
  21009. C
  21010. C
  21011. C
  21012.     crlf=char(13)//char(10)
  21013.     CALL TYPGET(INDXX,IX2,K)
  21014. C    K=TYPE(INDXX,IX2)
  21015.     IF (K.GT.0) GOTO 10
  21016. C MODIFY TO ELIMINATE CALL TO ERRMSG HERE. JUST COMPLAIN LOCALLY.
  21017.     CALL SWRT('Invalid type argument',21)
  21018.     oarry(1)=13
  21019.     oarry(2)=10
  21020.     call swrt(oarry,2)
  21021. C    CALL ERRMSG (16)
  21022.     GOTO 10000
  21023. 10    GOTO (100,200,300,400,500,600,700,800,900),K
  21024.     STOP 10
  21025. C
  21026. C
  21027. C
  21028. C
  21029. C **************************************************
  21030. C **************        ASCII        ***************
  21031. C **************************************************
  21032. 100    STAR1=AVBLS(1,INDXX)
  21033.     IF(OSWIT.NE.0)GOTO 6006
  21034.     IF (ICHAR(STAR1).LT.32) GOTO 110
  21035. 102    Continue
  21036. c    Rewind 11
  21037.     call vwrt(star1,1)
  21038. c    WRITE (11,103) STAR1
  21039. c    Rewind 11
  21040. 103    FORMAT (1X,A1)
  21041.     RETURN
  21042. 110    STAR1=CHAR(ICHAR(STAR1)+32)
  21043. c    Rewind 11
  21044.     Call vwrt('^' // star1,2)
  21045. c    WRITE (11,112) STAR1
  21046. c    Rewind 11
  21047. 112    FORMAT (1X,'^',A1)
  21048.     RETURN
  21049. 6006    OARRY(1)=STAR1
  21050.     OCNTR=1
  21051.     RETURN
  21052. C
  21053. C
  21054. C
  21055. C
  21056. C
  21057. C **************************************************
  21058. C ****************  DECIMAL   **********************
  21059. C **************************************************
  21060. 200    CONTINUE
  21061.     DO 208 I=1,8
  21062. 208    EIGHT(I)=AVBLS(I,INDXX)
  21063.     MAG=DABS(REAL)
  21064.     IF (MAG.LT.1.D0) GOTO 240
  21065. C
  21066. C
  21067. C COUNT THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
  21068.     P10=1.D0
  21069.     DO 210 I=1,38
  21070.     P10=10.D0*P10
  21071.     IF (P10.GT.MAG) GOTO 212
  21072. 210    CONTINUE
  21073. C
  21074. C I COUNTS THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
  21075.     I=39
  21076. 212    DEC=0
  21077.     WIDTH=17
  21078.     IF(I.GT.15)WIDTH=I+2
  21079.     IF(I.LE.15)DEC=15-I
  21080. C
  21081. C
  21082. C  CREATE PROPER FORMAT STATEMENT
  21083. 215    I1=WIDTH/10
  21084.     I2=WIDTH-I1*10
  21085.     IF (I2.EQ.0) I2=10
  21086.     DFORM(6)=DIGITS(I1,1)
  21087.     DFORM(7)=DIGITS(I2,1)
  21088.     I1=DEC/10
  21089.     I2=DEC-I1*10
  21090.     IF (I1.EQ.0) I1=10
  21091.     IF (I2.EQ.0) I2=10
  21092.     IPT=9
  21093.     IF (I1.EQ.0) GOTO 220
  21094.     DFORM(9)=DIGITS(I1,1)
  21095.     IPT=IPT+1
  21096. 220    DFORM(IPT)=DIGITS(I2,1)
  21097.     DFORM(IPT+1)=RPAR
  21098.     nnn=ipt+2
  21099.     if(nnn.ge.11)goto 223
  21100.     do 224 nnnn=nnn,11
  21101. 224    dform(nnnn)=' '
  21102. 223    continue
  21103. C
  21104. C
  21105. C
  21106. C
  21107. C  OUTPUT REAL USING NEWLY CREATED
  21108. C  FORMAT STATEMENT HELD BY DFORM
  21109.     IF(OSWIT.NE.0)GOTO 6009
  21110. c    Rewind 11
  21111.     write(cwrk,dform,err=10000)real
  21112.     call vwrt(crlf,2)
  21113.     call vwrt(cwrk,len(cwrk))
  21114. c    WRITE (11,DFORM,ERR=10000) REAL
  21115. c    Rewind 11
  21116.     GOTO 10000
  21117. 6009    CONTINUE
  21118.     IF(OSWIT.EQ.2) GOTO 6101
  21119.     IF(OSWIT.GT.3)GOTO 7101
  21120.     DO 6010 OCNTR=1,106
  21121. 6010    OARRY(OCNTR)=0
  21122. 6101    CONTINUE
  21123. C FORGET THE ENCODE ... NEVER USED
  21124. C6101    ENCODE(100,DFORM,OARRY)REAL
  21125. 7101    OCNTR=100
  21126.     GOTO 10000
  21127. C
  21128. C
  21129. C  REAL LESS THAN 1.D0
  21130. 240    P10=1.D0
  21131.     DO 245 I=1,38
  21132.     P10=P10*.1D0
  21133.     IF (MAG.GE.P10) GOTO 250
  21134. 245    CONTINUE
  21135.     I=0
  21136. C
  21137. C I-1 REPRESENTS THE NUMBER OF LEADING ZEROS
  21138. 250    DEC=14+I
  21139.     WIDTH=DEC+3
  21140.     GOTO 215
  21141. C
  21142. C
  21143. C **************************************************
  21144. C *************  HEXADECIMAL  **********************
  21145. C **************************************************
  21146. C  HEXADECIMAL
  21147. 300    CONTINUE
  21148.     DO 302 I=1,4
  21149. 302    FOUR(I)=AVBLS(I,INDXX)
  21150.     ISV=1
  21151.     IF (INT.LT.0) ISV=2
  21152.     INT=IABS(INT)
  21153.     L=8
  21154.     DO 304 I=1,4
  21155. C PICK UP A VALUE, THEN USE InTeGer*4 EQUIVALENT
  21156. C TO WORK WITH SO SIGN DOESN'T GET EXTENED.
  21157.     TWO(1)=ICHAR(FOUR(I))
  21158.     M1=ITWO/16
  21159.     M2=ITWO-M1*16
  21160.     IF(M1.EQ.0)M1=16
  21161.     IF(M2.EQ.0)M2=16
  21162.     EIGHT(L)=DIGITS(M2,3)
  21163.     L=L-1
  21164.     EIGHT(L)=DIGITS(M1,3)
  21165.     L=L-1
  21166. 304    CONTINUE
  21167.     IF(OSWIT.NE.0)GOTO 6011
  21168. c    Rewind 11
  21169.     write(cwrk,310,err=10000)sign(isv),eight
  21170.     call vwrt(crlf,2)
  21171.     Call vwrt(cwrk,len(cwrk))
  21172. c    WRITE (11,310,ERR=10000) SIGN(ISV), EIGHT
  21173. c    Rewind 11
  21174. 310    FORMAT (1X,1A1,8A1,2X,'(BASE 16)')
  21175.     GOTO 10000
  21176. 6011    CONTINUE
  21177.     IF(OSWIT.EQ.2)GOTO 6102
  21178.     IF(OSWIT.GT.3)GOTO 7102
  21179.     DO 6013 OCNTR=1,106
  21180. 6013    OARRY(OCNTR)=0
  21181. 6102    CONTINUE
  21182. C FORGET UNUSED ENCODE
  21183. C6102    ENCODE(8,6012,OARRY)SIGN(ISV),EIGHT
  21184. 6012    FORMAT(A1,8A1)
  21185. 7102    OCNTR=9
  21186.     GOTO 10000
  21187. C
  21188. C
  21189. C **************************************************
  21190. C ***************   INTEGER   **********************
  21191. C **************************************************
  21192. 400    DO 404 I=1,4
  21193. 404    FOUR(I)=AVBLS(I,INDXX)
  21194.     IF(OSWIT.NE.0)GOTO 6014
  21195. c    Rewind 11
  21196.     Write(cwrk,410,err=10000)int
  21197.     call vwrt(crlf,2)
  21198.     call vwrt(cwrk,len(cwrk))
  21199. c    WRITE (11,410,ERR=10000) INT
  21200. c    Rewind 11
  21201. 410    FORMAT (1X,I12)
  21202.     GOTO 10000
  21203. 6014    CONTINUE
  21204.     IF(OSWIT.EQ.2)GOTO 6103
  21205.     IF(OSWIT.GT.3)GOTO 7104
  21206.     DO 6015 OCNTR=1,106
  21207. 6015    OARRY(OCNTR)=0
  21208. 6103    CONTINUE
  21209. C6103    ENCODE(12,410,OARRY)INT
  21210. 7104    OCNTR=12
  21211.     GOTO 10000
  21212. C
  21213. C
  21214. C **************************************************
  21215. C ***********    MULTIPLE PRECISION   **************
  21216. C **************************************************
  21217. C  MULTIPLE PRECISION
  21218. C  M10
  21219. 500    CONTINUE
  21220. C
  21221. C  M8
  21222. 600    CONTINUE
  21223. C
  21224. C  M16
  21225. 700    continue
  21226. c700    CALL MOUT (INDXX,RETCD)
  21227.     GOTO 10000
  21228. C
  21229. C
  21230. C **************************************************
  21231. C ****************   OCTAL   ***********************
  21232. C **************************************************
  21233. C  OCTAL
  21234. 800    DO 804 I=1,4
  21235. 804    FOUR(I)=AVBLS(I,INDXX)
  21236.     ISV=1
  21237.     IF (INT.LT.0) ISV=2
  21238.     K=IABS(INT)
  21239.     DO 810 I=1,11
  21240.     L=K-K/8*8
  21241. C TAKE ABSOLUTE VALUE IN CASE FIRST IABS DIDN'T WORK ON -2**31
  21242.     L=IABS(L)
  21243.     IF(L.EQ.0)L=9
  21244.     LEVIN (12-I)=DIGITS(L,2)
  21245.     K=K/8
  21246. 810    CONTINUE
  21247.     IF(OSWIT.NE.0)GOTO 6016
  21248. c    Rewind 11
  21249.     write(cwrk,820,err=10000)sign(isv),levin
  21250.     call vwrt(crlf,2)
  21251.     call vwrt(cwrk,len(cwrk))
  21252. c    WRITE (11,820,ERR=10000) SIGN(ISV), LEVIN
  21253. c    Rewind 11
  21254. 820    FORMAT (1X,1A1,11A1,2X,'(BASE 8)')
  21255.     GOTO 10000
  21256. 6016    CONTINUE
  21257.     IF(OSWIT.EQ.2)GOTO 6100
  21258.     IF(OSWIT.GT.3)GOTO 7105
  21259.     DO 6018 OCNTR=1,106
  21260. 6018    OARRY(OCNTR)=0
  21261. 6100    CONTINUE
  21262. C6100    ENCODE(12,6017,OARRY)SIGN(ISV),LEVIN
  21263. 6017    FORMAT(12A1)
  21264. 7105    OCNTR=12
  21265.     GOTO 10000
  21266. C
  21267. C
  21268. C
  21269. C
  21270. C
  21271. C **************************************************
  21272. C ***************    REAL    ***********************
  21273. C **************************************************
  21274. 900    DO 904 I=1,8
  21275. 904    EIGHT(I)=AVBLS(I,INDXX)
  21276.     IF(OSWIT.NE.0)GOTO 6019
  21277. c    Rewind 11
  21278.     write(cwrk,910,err=10000)real
  21279.     call vwrt(crlf,2)
  21280.     call vwrt(cwrk,len(cwrk))
  21281. c    WRITE (11,910,ERR=10000) REAL
  21282. c    Rewind 11
  21283. 910    FORMAT (1X,D25.18)
  21284.     GOTO 10000
  21285. 6019    CONTINUE
  21286.     IF (OSWIT.EQ.2)GOTO 6020
  21287.     IF(OSWIT.GT.3)GOTO 7106
  21288.     DO 6321 OCNTR=1,106
  21289. 6321    OARRY(OCNTR)=Char(0)
  21290. 6020    CONTINUE
  21291. C    ENCODE(28,6021,OARRY)REAL
  21292. 6021    FORMAT(D25.18)
  21293. 7106    OCNTR=28
  21294. 10000    RETURN
  21295.     END
  21296. c -h- vblget.for    Fri Aug 22 13:37:17 1986    
  21297.         SUBROUTINE VBLGET(ID1,ID2,ID3,IVAL)
  21298. C
  21299. C VBLGET - GET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY
  21300. C  DIMENSIONED (8,60,301). HANDLE BY CALLING XVBLGT TO GET
  21301. C  CORRECT 8 BYTE VARIABLE, AND PULLING OUT CORRECT ONE
  21302.         InTeGer*4 ID1,ID2,ID3
  21303.         CHARACTER*1 IVAL,LL(8)
  21304.         REAL*8 XX
  21305.         EQUIVALENCE(LL(1),XX)
  21306.         CALL XVBLGT(ID2,ID3,XX)
  21307.         IVAL=LL(ID1)
  21308.         RETURN
  21309.         END
  21310. c -h- vblset.for    Fri Aug 22 13:37:17 1986    
  21311.         SUBROUTINE VBLSET(ID1,ID2,ID3,IVAL)
  21312. C VBLSET - SET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY
  21313. C  DIMENSIONED (8,60,301). HANDLE BY CALLING XVBLST TO GET
  21314. C  CORRECT 8 BYTE VARIABLE, AND PUTTING IN CORRECT ONE
  21315.         InTeGer*4 ID1,ID2,ID3
  21316.         CHARACTER*1 IVAL,LL(8)
  21317.         REAL*8 XX
  21318.         EQUIVALENCE(LL(1),XX)
  21319. C GET THE DESIRED 8 BYTES, THEN CHANGE THE ONE WE WANT. THEN...
  21320.         CALL XVBLGT(ID2,ID3,XX)
  21321.         LL(ID1)=IVAL
  21322. C PUT BACK THE 8 BYTES.
  21323.         CALL XVBLST(ID2,ID3,XX)
  21324.         RETURN
  21325.         END
  21326. c -h- wassig.fdd    Fri Aug 22 13:44:20 1986    
  21327.     SUBROUTINE WASSIG(IUNIT,NAME)
  21328. C
  21329. C
  21330.     CHARACTER*1 NAME(50)
  21331.     InTeGer*4 IUNIT
  21332.     CHARACTER*20 WK
  21333.     CHARACTER*1 WK1(20)
  21334.     EQUIVALENCE(WK(1:1),WK1(1))
  21335. C JUST TRY AND NULL FILL A NAME TO USE.
  21336.     DO 1 N=1,20
  21337.     WK1(N)=' '
  21338. 1    CONTINUE
  21339.     DO 2 N=1,20
  21340.     II=ICHAR(NAME(N))
  21341.     IF(II.LT.32)GOTO 3
  21342.     WK1(N)=CHAR(II)
  21343. C1    CONTINUE
  21344. 2    CONTINUE
  21345. 3    OPEN(IUNIT,FILE=WK(1:20),STATUS='NEW',
  21346.      1  ACCESS='SEQUENTIAL',FORM='FORMATTED')
  21347.     RETURN
  21348.     END
  21349. c -h- wrkfil.f40    Fri Aug 22 13:44:46 1986    
  21350.     SUBROUTINE WRKFIL(NREC,ARRAY,IFUNC)
  21351. C COPYRIGHT 1983 GLENN C.EVERHART
  21352. C ALL RIGHTS RESERVED
  21353. C WORKFILE PSEUDO-MAINTAINER
  21354. C
  21355. C THIS ROUTINE IS INTENDED TO PERMIT THE SCRATCH FILE OF
  21356. C PORTACALC TO BE DISPENSED WITH BY USING A LARGE IN-MEMORY
  21357. C ARRAY. A BITMAP WILL SET UP WHEN THE ELEMENT IS INIT'ED AND
  21358. C THE DEFAULT ELEMENT WILL BE COMPUTED AND RETURNED
  21359. C IF AN UNINITIALIZED ELEMENT IS USED.
  21360. C
  21361. c nrc was i*4. make it i*2 here
  21362.     Include Aparms.Inc
  21363.     INTEGER NRC
  21364. C    InTeGer*4 NRC2(2)
  21365. C    EQUIVALENCE(NRC2(1),NRC)
  21366. C RECORD NUMBER TO ACCESS
  21367.     INTEGER NREC
  21368.     CHARACTER*1 ARRAY(128)
  21369.     INTEGER IFUNC
  21370. C ***<<<< RDD COMMON START >>>***
  21371.     InTeGer*4 RRWACT,RCLACT
  21372. C    COMMON/RCLACT/RRWACT,RCLACT
  21373.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  21374.      1  IDOL7,IDOL8
  21375. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  21376. C     1  IDOL7,IDOL8
  21377.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  21378. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  21379.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21380. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21381. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  21382. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  21383.     InTeGer*4 KLVL
  21384. C    COMMON/KLVL/KLVL
  21385.     InTeGer*4 IOLVL,IGOLD
  21386. C    COMMON/IOLVL/IOLVL
  21387. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  21388. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  21389.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  21390.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  21391.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  21392.      3  k3dfg,kcdelt,krdelt,kpag
  21393. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  21394. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  21395. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  21396. C ***<<< RDD COMMON END >>>***
  21397. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21398. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21399. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  21400. C
  21401. C ***<<< NULETC COMMON START >>>***
  21402.     InTeGer*4 ICREF,IRREF
  21403. C    COMMON/MIRROR/ICREF,IRREF
  21404.     InTeGer*4 MODPUB,LIMODE
  21405. C    COMMON/MODPUB/MODPUB,LIMODE
  21406.     InTeGer*4 KLKC,KLKR
  21407.     REAL*8 AACP,AACQ
  21408. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  21409.     InTeGer*4 NCEL,NXINI
  21410. C    COMMON/NCEL/NCEL,NXINI
  21411.     CHARACTER*1 NAMARY(20,MRows)
  21412. C    COMMON/NMNMNM/NAMARY
  21413.     InTeGer*4 NULAST,LFVD
  21414. C    COMMON/NULXXX/NULAST,LFVD
  21415.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  21416.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  21417. C ***<<< NULETC COMMON END >>>***
  21418. CCC    InTeGer*4 NCEL,NXINI
  21419. CCC    COMMON/NCEL/NCEL,NXINI
  21420.     InTeGer*4 MFID(2),MFMOD(2)
  21421.     InTeGer*2 IFID(8,MFrm)
  21422.     COMMON/IFIDC/IFID
  21423. CCC    InTeGer*4 RRWACT,RCLACT
  21424. C MFLAST = 1 OR 2 FOR LAST BUFFER USED. MFBASE IS HOLDER FOR "BASE ADDR"
  21425. C IN ARRAY TO USE IN SCANS.
  21426.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  21427.     COMMON/VBCTL/MFLAST,MFBASE,MVLASE,MVBASE
  21428. CCC    COMMON/RCLACT/RRWACT,RCLACT
  21429.     CHARACTER*1 LFID(16,MFrm)
  21430.     EQUIVALENCE(IFID(1,1),LFID(1,1))
  21431. C ***<<< KLSTO COMMON START >>>***
  21432.     InTeGer*4 DLFG
  21433. C    COMMON/DLFG/DLFG
  21434.     InTeGer*4 KDRW,KDCL
  21435. C    COMMON/DOT/KDRW,KDCL
  21436.     InTeGer*4 DTRENA
  21437. C    COMMON/DTRCMN/DTRENA
  21438.     REAL*8 EP,PV,FV
  21439.     DIMENSION EP(20)
  21440.     INTEGER*4 KIRR
  21441. C    COMMON/ERNPER/EP,PV,FV,KIRR
  21442.     InTeGer*4 LASTOP
  21443. C    COMMON/ERROR/LASTOP
  21444.     CHARACTER*1 FMTDAT(9,76)
  21445. C    COMMON/FMTBFR/FMTDAT
  21446.     CHARACTER*1 EDNAM(16)
  21447. C    COMMON/EDNAM/EDNAM
  21448. c    InTeGer*4 MFID(2),MFMOD(2)
  21449. C    COMMON/FRM/MFID,MFMOD
  21450.     InTeGer*4 JMVFG,JMVOLD
  21451. C    COMMON/FUBAR/JMVFG,JMVOLD
  21452.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  21453.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  21454. C ***<<< KLSTO COMMON END >>>***
  21455. CCC    COMMON/FRM/MFID,MFMOD
  21456.     CHARACTER*1 LI,IBYTE
  21457. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  21458.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  21459.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  21460.     COMMON/DEFVBX/DVFMT
  21461. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  21462. C AREAS WITH DATA.)
  21463. CCC    CHARACTER*1 FMTDAT(9,76)
  21464. CCC    COMMON/FMTBFR/FMTDAT
  21465. C
  21466. C IFUNC SPECIFIES WHAT TO DO:
  21467. C    =0    READ INTO ARRAY
  21468. C    =1    WRITE FROM ARRAY INTO WRKARY
  21469. C    =2    INITIALIZE (JUST CLEARS BITMAP HERE)(OPEN)
  21470. C    =3    CLOSE (CLEARS BITMAP HERE)
  21471.     CHARACTER*1 DTBL1(9,9,8)
  21472. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  21473.     InTeGer*2 BTBL(6,6,8)
  21474. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  21475. C NO NEED TO WASTE IT.
  21476.     INTEGER DTBLIN
  21477. C DTBLIN FLAGS THAT DTBL1 WAS ALREADY INITED, SO ONLY DOES SO ONCE.
  21478.     EQUIVALENCE(LFID(1,1),BTBL(1,1,1))
  21479.     InTeGer*2 BTBL1(6,6)
  21480.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  21481.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  21482.     EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  21483.     EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  21484.     EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  21485.     EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  21486.     COMMON /DECIDE/ DTBL1
  21487.     DATA DTBLIN/0/
  21488.     IF(IFUNC.NE.50)GOTO 34
  21489.     IF(DTBLIN.NE.0)RETURN
  21490.     DTBLIN=1
  21491. C FLAG WE DID THIS INITIALIZATION ONCE. SINCE BUFFER IS CLEARED WE MUST
  21492. C *** NOT *** DO IT AGAIN.
  21493. C ONLY INIT DTBL1 ENTRIES NOT CORRESPONDING TO MULTIPLE PRECISION DATA
  21494. C TYPES (WHICH ARE NOT SUPPORTED HERE)
  21495. C CALL SEPARATE ROUTINE TO CLEAR OUT THIS STUFF ONE-TIME. OVERLAY SAME.
  21496. C NOTE LOTS OF SILLY ARGUMENTS TO SUBROUTINE SINCE MS FORTRAN DISALLOWS
  21497. C EQUIVALENCES TO DUMMY ARGUMENTS.
  21498.     CALL WTBINI(IFID,LPGMXF,BTBL1,BTBL2,BTBL3,BTBL4,BTBL5,BTBL6,
  21499.      1  BTBL7,BTBL8)
  21500. C
  21501. C14      CONTINUE
  21502. CC FILE IS NOW CLEARED
  21503.     RETURN
  21504. 34    IF(IFUNC.LT.0.OR.IFUNC.GT.3)RETURN
  21505.     JFUN=IFUNC+1
  21506.     GOTO (1000,2000,3000,4000),JFUN
  21507. 1000    CONTINUE
  21508. C READ
  21509.     CALL FVLDGT(NREC,1,IBYTE)
  21510.     IF(ICHAR(IBYTE).NE.0)GOTO 1001
  21511. C UNINITIALIZED ARRAY ELEMENT: SET IT UP.
  21512. C JUST LEAVES DUMMY CELL CONTENTS WHERE NOTHING IS REALLY INIT'D.
  21513.     DO 1003 N=1,128
  21514. 1003    ARRAY(N)=char(0)
  21515.     ARRAY(1)='P'
  21516.     ARRAY(2)='#'
  21517.     ARRAY(3)='0'
  21518.     ARRAY(5)='0'
  21519.     ARRAY(4)='#'
  21520.     ARRAY(118)=CHAR(15)
  21521. C NOTE ARRAY(119) (WHICH BECOMES FVLD) IS 0 TOO.
  21522.     DO 1004 N=1,9
  21523. 1004    ARRAY(N+119)=DEFFMT(N)
  21524. C RETURN THE DEFAULT FORMAT NOW.
  21525.     RETURN
  21526. 1001    CONTINUE
  21527. C HERE HAVE TO GET THE WHOLE THING REALLY
  21528.     DO 1053 N=1,128
  21529. 1053    ARRAY(N)=char(0)
  21530.     ARRAY(119)=IBYTE
  21531.     ARRAY(118)=CHAR(15)
  21532.     ARRAY(1)=char(48)
  21533. C LET ARRAY INITIALLY BE SET SENSIBLY..
  21534.     DO 1054 N=1,9
  21535. 1054    ARRAY(N+119)=DEFFMT(N)
  21536. C WE MAY MODIFY FORMAT LATER TOO...
  21537. C NOW HAVE A NON-DEFAULT ELEMENT TO READ... GO THROUGH SYMBOL TBL LOGIC
  21538. C FOR THESE, WE USE 16-BYTE "CELLS" WHICH HAVE THE FOLLOWING FORMAT:
  21539. C    ID    2 BYTES (CELL ADDRESS, MUST BE 1 OR MORE FOR VALID)
  21540. C    FLAG    1 BYTE  (TYPE OF CELL:
  21541. C                0 = UNUSED
  21542. C                1 = 1 OF 1 CELLS
  21543. C                2 = NONTERMINAL OF MORE THAN 1 CELL
  21544. C                3 = LAST OF >1 CELLS
  21545. C    FORMAT    1 BYTE  (INDEX OF FORMAT STRING FOR THIS CELL; FORMATS
  21546. C                ARE STORED RESIDENT, UP TO 76 OF THEM,
  21547. C                SET BY DF COMMAND.)
  21548. C    FORMULA    12 BYTES  (FORMULA TEXT)
  21549. C SET UP HASH CODE NOW FOR THE WAY WE NEED...
  21550. C    IPM=(LPGMXF*64/2048)+1
  21551. C    IBF=64
  21552. CC    IBF=(2048+31)/32
  21553. C IBF IS NO. OF ENTRIES IN A BUFFER. OF 512 BYTES
  21554. C    IBF=32
  21555.     IBF=(MFrm+31)/64
  21556. C    LLL=(LPGMXF)/IBF
  21557. C    LLL=LPGMXF
  21558. C IPM IS NO. PAGES MAX IN FILS
  21559. C 1024 bytes holds 64 entries at 16 bytes each
  21560. C (user specifies file in K)
  21561. C handle in 1024 units since we have 2 buffers
  21562.     IPM=LPGMXF*64/(MFrmo2)
  21563. C EACH BUFFER HAS 16KB (if mfrm=2048) SO MAX PAGES IS (FILE LENGTH)/16
  21564. C    IPM=LLL
  21565.     IF(IPM.LT.2)IPM=2
  21566. C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
  21567.     IHASH=NREC
  21568. C    JHASH=IMASK(IHASH,(MFrm-1))
  21569.     JHASH=MOD(IHASH,(MFrmo2))
  21570. C    JHASH=IMASK(IHASH,1023)
  21571. C    JHASH=MOD(IHASH,2048)
  21572.     IF(LPGMOD.NE.0)GOTO 5305
  21573. C    IPAG=(IHASH/2048)+1
  21574.     IPAG=(IHASH/(MFrmo2))+1
  21575.     IPAG=MOD(IPAG,IPM)+1
  21576.     GOTO 5306
  21577. 5305    CONTINUE
  21578. C SPEED OPTIMAL PACK
  21579.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FLOAT(LPGMOD)
  21580.     IPAG=FPG
  21581.     IPAG=MOD(IPAG,IPM)
  21582.     IPAG=IPAG+1
  21583. C    IPAG=1+(IHASH*IPM)/18060
  21584. 5306    CONTINUE
  21585. C HERE DECIDED IF PAGE IS WHAT WE NEED.
  21586. C
  21587. C    IF(IPAG.LE.0)IPAG=1
  21588. C DETERMINE FIRST THAT NEITHER PAGE NUMBER IS ZERO.
  21589.     IF(IPAG.EQ.MFID(1).OR.IPAG.EQ.MFID(2))GOTO 853
  21590.     IF(MFID(1).NE.0)GOTO 852
  21591.     MFID(1)=IPAG
  21592.     GOTO 853
  21593. 852    IF(MFID(2).EQ.0)MFID(2)=IPAG
  21594. 853    CONTINUE
  21595.     IF(MFID(1).EQ.IPAG) GOTO 850
  21596.     IF(MFID(2).EQ.IPAG)GOTO 851
  21597.     GOTO 854
  21598. 850    CONTINUE
  21599. C PAGE 1 IS THE ONE WE NEED.
  21600.     MFLAST=1
  21601.     MFBASE=0
  21602.     GOTO 1400
  21603. 851    CONTINUE
  21604. C NEED SECOND PAGE
  21605.     MFLAST=2
  21606.     MFBASE=(MFrmo2)
  21607. C BASE IS HASFWAY ALONG FILE...
  21608.     GOTO 1400
  21609. 854    CONTINUE
  21610. C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
  21611. C MFLAST will be either 1 or 2; following logic swaps them.
  21612.     MFLAST=3-MFLAST
  21613.     MFBASE=(MFrmo2)-MFBASE
  21614. C SIMILAR LOGIC SAYS MFBAS4E IS EITHER 0 OR MFrmo2. INITIALIZED IN
  21615. C WSSET TO 0.
  21616. C NOTE THAT IF MFLAST=1,MBFN=1 AND IF MFLAST=2,NEW MFLAST=1
  21617. C THIS GIVES BUFFER TO REPLACE... (LRU)
  21618. C
  21619. C IF MFLAST=2 REPLACE BUFFER 1, ELSE REPLACE BUFFER 0
  21620. C NOW MFID HAS MEMORY PAGE CURRENTLY PRESENT, IPAG IS DESIRED ONE FOR THIS
  21621. C FORMULA. NOTE WHILE WE USE A HASHCODE TO SEARCH FOR FORMULAS, ALL SEGMENTS
  21622. C OF A FORMULA MUST BE PLACED IN ONE MEMORY PAGE. THUS, IT IS POSSIBLE TO
  21623. C RUN OUT OF SPACE IF THE MEMORY BUFFER GETS TOO SMALL. CURRENT HASH
  21624. C CODE TRIES TO SPREAD THE FORMULAS OUT, BUT BIG MEMORY BUFFERS ALWAYS
  21625. C WIN.....
  21626.     IF(LPGMXF.LE.(MFro64))GOTO 1400
  21627. C    IF(LPGMXF.LE.(2048/64))GOTO 1400
  21628. C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
  21629. C    IBF=32
  21630. CC    IBF=(1024+31)/32
  21631. C    IF(IBF.LT.1)IBF=1
  21632. C IBF IS BLK FACTOR FOR ONE WRITE
  21633. C WRITE 512 BYTES AT A TIME.
  21634.     L=1+MFBASE
  21635.     LLBK=(MFID(MFLAST)-1)*IBF+1
  21636.     LHBK=MFID(MFLAST)*IBF
  21637.     DO 1170 N=LLBK,LHBK
  21638.     IF(MFMOD(MFLAST).EQ.0)GOTO 1170
  21639.     LL=L+(MFro64)-1
  21640.     WRITE(7,REC=N,ERR=1170)((IFID(K,KK),K=1,8),KK=L,LL)
  21641.     L=L+(MFro64)
  21642. 1170    CONTINUE
  21643. C NOW READ IN THE DATA
  21644.     MFMOD(MFLAST)=0
  21645. C MARK PAGE UNTOUCHED. READING DOES NOT ALTER DATA SO NO NEED
  21646. C TO WRITE OUT UNLESS MODIFIED.
  21647.     MFID(MFLAST)=IPAG
  21648.     L=1+MFBASE
  21649.     LLBK=(MFID(MFLAST)-1)*IBF+1
  21650.     LHBK=MFID(MFLAST)*IBF
  21651.     DO 1171 N=LLBK,LHBK
  21652.     LL=L+(MFro64)-1
  21653.     READ(7,REC=N,ERR=1171)((IFID(K,KK),K=1,8),KK=L,LL)
  21654.     L=L+(MFro64)
  21655. 1171    CONTINUE
  21656. C DATA ALL SHOULD BE THERE NOW... OK, GO AHEAD.
  21657. 1400    CONTINUE
  21658. C NOW HAVE THE DESIRED MEMORY PAGE; READ THE FORMULA INTO ARRAY
  21659. C BUFFER.
  21660.     IARSUB=1
  21661. C FOR SIMPLICITY FORGET THE HASHCODE WITHIN MEMORY BUFFERS, JUST SEARCH
  21662. C FROM START...
  21663.     IFLAG=0
  21664.     IFMT=0
  21665.     DO 2500 NN=1,(MFrmo2)
  21666. c    N=MOD((NN+JHASH-1),(MFrmo2))
  21667.     N=MOD((NN+JHASH),(MFrmo2))
  21668.     N=N+1+MFBASE
  21669. C    N=IMASK((NN+JHASH-1),1023)+1+MFBASE
  21670.     KKKKK=IFID(1,N)
  21671.     IF(NN.GT.2.AND.KKKKK.EQ.-1)GOTO 2505
  21672.     IF(KKKKK.NE.NREC)GOTO 2500
  21673.     IFLAG=ICHAR(LFID(3,N))
  21674.     IF(IFMT.EQ.0)IFMT=ICHAR(LFID(4,N))
  21675. C for the moment leave this in. LAter remove and change to 10
  21676. C bytes formula, 4 bytes cell ID.
  21677.     DO 2502 K=1,12
  21678.     LI=LFID(K+4,N)
  21679. C COPY FORMULA TEXT INTO ARRAY. END ON NULLS...
  21680.     IF(ICHAR(LI).LE.0)GOTO 2505
  21681.     ARRAY(IARSUB)=LI
  21682. c null out following characters since -1's could be misinterpreted as data
  21683.     array(iarsub+1)=0
  21684.     array(iarsub+2)=0
  21685.     IARSUB=IARSUB+1
  21686. 2502    CONTINUE
  21687.     IF(IFLAG.EQ.1.OR.IFLAG.EQ.3)GOTO 2505
  21688. 2500    CONTINUE
  21689. 2505    CONTINUE
  21690. C GET FORMAT NOW...
  21691.     IF(IFMT.LE.0)RETURN
  21692.     DO 2510 N=1,9
  21693. 2510    ARRAY(119+N)=FMTDAT(N,IFMT)
  21694.     GOTO 5000
  21695. 2000    CONTINUE
  21696. C WRITE
  21697. C NOW SET INIT'D BIT; WRITE ARRAY ELEMENT OUT.
  21698. C FIRST FIND FORMAT AREA OR SET IT UP.
  21699.     IFMT=0
  21700.     LFF=0
  21701. C FAKE OUT THE SAVING OF FVLD INFO IN THIS ARRAY TOO.
  21702. C THIS IS INCOMPLETE AND NO LITTLE OF A KLUDGE BUT THE CODE WILL
  21703. C GENERALLY SET THEM TOGETHER, AND THIS GUARANTEES THAT IF
  21704. C FURTHER SETS TRY TO SET FVLD TO ARRAY(119), THEY'LL WORK AS
  21705. C THEY SHOULD.
  21706. C HERE SET MAX ARRAY ELEMENTS USED
  21707. C EXPECT (ID2-1)*60+ID1
  21708. C ID1 IS 60 DIM, ID2 IS 301 DIM
  21709. C    NRC2(2)=0
  21710. C    NRC2(1)=NREC
  21711. C JUST EQUATE NRC TO NREC
  21712. C ALLOW LATER FOR OVER 32768 ELEMENTS... NO NEED TO JUST YET
  21713. C WHEN WE DO, REPLACE NRC2 STUFF (WHOSE PURPOSE IS TO AVOID
  21714. C SIGN EXTENSIONS).
  21715. C NEXT KEEP TRACK OF LOWER RIGHT CORNER OF AREA IN USE.
  21716.     NRC=NREC-1
  21717.     IRUSED=MOD(NRC,MCols)+1
  21718.     ICUSED=((NRC-IRUSED+1)/MCols)+1
  21719.     IF(ICUSED.GT.RCLACT)RCLACT=ICUSED
  21720.     IF(IRUSED.GT.RRWACT)RRWACT=IRUSED
  21721. C SET RRWACT, RCLACT
  21722.     IF(ICHAR(ARRAY(119)).NE.0)CALL FVLDST(NREC,1,ARRAY(119))
  21723.     DO 2011 N=1,76
  21724.     IF(ICHAR(FMTDAT(1,N)).LE.0.AND.LFF.EQ.0)LFF=N
  21725. C SAVE FIRST FREE FORMAT AREA IN CASE THIS IS A NEW FORMAT...
  21726.     DO 2010 M=1,9
  21727.     IF(ARRAY(M+119).NE.FMTDAT(M,N))GOTO 2011
  21728. 2010    CONTINUE
  21729.     IFMT=N
  21730.     GOTO 2012
  21731. 2011    CONTINUE
  21732. C ON FALL THROUGH, WE FOUND NOTHING FOR IT...
  21733. C USE HIS FORMAT UNLESS WE HAVE NO ROOM, IN WHICH CASE USE LAST AREA
  21734.     IF(LFF.EQ.0)LFF=76
  21735.     IFMT=LFF
  21736.     DO 2013 N=1,9
  21737. 2013    FMTDAT(N,LFF)=ARRAY(119+N)
  21738. C SAVE FORMAT DATA WE NOW POINT TO...
  21739. 2012    CONTINUE
  21740. C NOW THE HARDER PART... MUST WRITE THE ARRAY'S FORMULA TOO...
  21741. C    IPM=(LPGMXF*64/2048)+1
  21742.     IBF=(MFro64)
  21743. C    IBF=(2048+31)/32/2
  21744. C    LLL=(LPGMXF*2)/IBF
  21745. C    IPM=LLL
  21746.     IPM=LPGMXF*64/MFrmo2
  21747. C IPM = NO. PAGES IN FILE. LPGMXF/(LENGTH OF ONE MEM BUFFER IN K).
  21748.     IF(IPM.LT.2)IPM=2
  21749. C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
  21750.     IHASH=NREC
  21751. C    JHASH=IMASK(IHASH,1023)
  21752.     JHASH=MOD(IHASH,(MFrmo2))
  21753.     IF(LPGMOD.NE.0)GOTO 5307
  21754.     IPAG=(IHASH/(MFrmo2))+1
  21755.     IPAG=MOD(IPAG,IPM)+1
  21756.     GOTO 5308
  21757. 5307    CONTINUE
  21758. C SPEED OPTIMAL PACK
  21759.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FLOAT(LPGMOD)
  21760.     IPAG=FPG
  21761.     IPAG=MOD(IPAG,IPM)
  21762.     IPAG=IPAG+1
  21763. C    IPAG=1+(IHASH*IPM)/18060
  21764. 5308    CONTINUE
  21765. C ***
  21766. C DETERMINE FIRST THAT NEITHER PAGE NUMBER IS ZERO.
  21767.     IF(IPAG.EQ.MFID(1).OR.IPAG.EQ.MFID(2))GOTO 953
  21768.     IF(MFID(1).NE.0)GOTO 952
  21769.     MFID(1)=IPAG
  21770.     GOTO 953
  21771. 952    IF(MFID(2).EQ.0)MFID(2)=IPAG
  21772. 953    CONTINUE
  21773.     IF(MFID(2).EQ.IPAG)GOTO 951
  21774.     IF(MFID(1).NE.IPAG) GOTO 954
  21775. 950    CONTINUE
  21776. C PAGE 1 IS THE ONE WE NEED.
  21777.     MFLAST=1
  21778.     MFBASE=0
  21779.     GOTO 2400
  21780. 951    CONTINUE
  21781. C NEED SECOND PAGE
  21782.     MFLAST=2
  21783.     MFBASE=(MFrmo2)
  21784. C BASE IS HASFWAY ALONG FILE...
  21785.     GOTO 2400
  21786. 954    CONTINUE
  21787. C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
  21788.     MFLAST=3-MFLAST
  21789.     MFBASE=(MFrmo2)-MFBASE
  21790. C ***
  21791. C NOW MFID HAS MEMORY PAGE CURRENTLY PRESENT, IPAG IS DESIRED ONE FOR THIS
  21792. C FORMULA. NOTE WHILE WE USE A HASHCODE TO SEARCH FOR FORMULAS, ALL SEGMENTS
  21793. C OF A FORMULA MUST BE PLACED IN ONE MEMORY PAGE. THUS, IT IS POSSIBLE TO
  21794. C RUN OUT OF SPACE IF THE MEMORY BUFFER GETS TOO SMALL. CURRENT HASH
  21795. C CODE TRIES TO SPREAD THE FORMULAS OUT, BUT BIG MEMORY BUFFERS ALWAYS
  21796. C WIN.....
  21797.     IF(LPGMXF.LE.(MFro64))GOTO 2400
  21798. C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
  21799. C    IBF=(1024+31)/32
  21800. C    IBF=32
  21801. C IBF IS BLK FACTOR
  21802.     L=1+MFBASE
  21803.     LLBK=(MFID(MFLAST)-1)*IBF+1
  21804.     LHBK=MFID(MFLAST)*IBF
  21805.     DO 2170 N=LLBK,LHBK
  21806.     IF(MFMOD(MFLAST).EQ.0)GOTO 2170
  21807.     LL=L+(MFro64)-1
  21808.     WRITE(7,REC=N,ERR=2170)((IFID(K,KK),K=1,8),KK=L,LL)
  21809.     L=L+(MFro64)
  21810. 2170    CONTINUE
  21811. C NOW READ IN THE DATA
  21812. C MARK NEW PAGE TOUCHED SINCE WE WILL DO SO HERE
  21813. C    MFMOD=1
  21814.     MFID(MFLAST)=IPAG
  21815.     L=1+MFBASE
  21816.     LLBK=(MFID(MFLAST)-1)*IBF+1
  21817.     LHBK=MFID(MFLAST)*IBF
  21818.     DO 2171 N=LLBK,LHBK
  21819.     LL=L+(MFro64)-1
  21820.     READ(7,REC=N,ERR=2171)((IFID(K,KK),K=1,8),KK=L,LL)
  21821.     L=L+(MFro64)
  21822. 2171    CONTINUE
  21823. C DATA ALL SHOULD BE THERE NOW... OK, GO AHEAD.
  21824. 2400    CONTINUE
  21825. C NOW HAVE THE DESIRED MEMORY PAGE; READ THE FORMULA INTO ARRAY
  21826. C BUFFER.
  21827.     MFMOD(MFLAST)=1
  21828.     IARSUB=1
  21829. C FOR SIMPLICITY FORGET THE HASHCODE WITHIN MEMORY BUFFERS, JUST SEARCH
  21830. C FROM START...
  21831. C OMIT THE ZEROING WHEN READING IN FROM FILE EXCEPT IN /MERGE MODE
  21832.     IF(NXINI.NE.0)GOTO 6233
  21833.     DO 1490 NN=1,(MFrmo2)
  21834.     N=MOD((NN+JHASH),(MFrmo2))+1+MFBASE
  21835. C    N=IMASK((NN+JHASH),1023)+1+MFBASE
  21836.     KKKKK=IFID(1,N)
  21837.     IF(NN.GT.2.AND.KKKKK.EQ.-1)GOTO 6233
  21838. C SKIP ZEROING ONCE WE ENCOUNTER A VIRGIN CELL SINCE WE WOULD ALWAYS
  21839. C CLEAR TO NONVIRGIN STATUS AFTERWARDS.
  21840.     IF(KKKKK.NE.NREC)GOTO 1490
  21841. C ZERO OLD RECORDS OF THIS ONE...
  21842.     NCEL=NCEL-1
  21843.     IF(NCEL.LT.0)NCEL=0
  21844.     DO 1498 KK=1,8
  21845. 1498    IFID(KK,N)=0
  21846. 1490    CONTINUE
  21847. 6233    CONTINUE
  21848.     IFLAG=0
  21849.     DO 1500 NN=1,(MFrmo2)
  21850.     N=MOD((NN+JHASH),(MFrmo2))+1+MFBASE
  21851. C    N=IMASK((NN+JHASH),1023)+1+MFBASE
  21852.     KKKKK=IFID(1,N)
  21853.     IF(KKKKK.NE.-1.AND.KKKKK.NE.0
  21854.      1     .AND.KKKKK.NE.NREC)GOTO 1500
  21855. C FOUND A NULL NODE...
  21856. C FILL IT IN NOW.
  21857.     NCEL=NCEL+1
  21858.     IFID(1,N)=NREC
  21859.     IFLAG=1
  21860.     LFID(4,N)=CHAR(IFMT)
  21861.     LFID(3,N)=CHAR(IFLAG)
  21862. c zero new elements to ensure no extra -1's get handled as
  21863. c data. Important because they could be mistaken for cell codings now.
  21864.     do 4502 k=1,12
  21865. 4502    lfid(k+4,n)=CHAR(0)
  21866.     DO 1502 K=1,12
  21867.     LI=ARRAY(IARSUB)
  21868.     IF(ICHAR(LI).LE.0)GOTO 1505
  21869. C CHOP IT OFF AT 109 ALSO...
  21870.     IF(IARSUB.GT.109)GOTO 1560
  21871.     LFID(K+4,N)=LI
  21872.     IARSUB=IARSUB+1
  21873. 1502    CONTINUE
  21874. C NONTERMINAL COPY...NEED ANOTHER CELL. FIRST TEST FOR EXACT FIT,
  21875. C HOWEVER.
  21876.     IF(ICHAR(ARRAY(IARSUB)).LE.0)GOTO 1560
  21877.     IFLAG=2
  21878.     LFID(3,N)=CHAR(IFLAG)
  21879. C NOW GO GET MORE SPACE FOR NEXT NODE.
  21880. C NOTE IT COULD RUN OUT, BUT JUST PUNT THAT.
  21881.     GOTO 1500
  21882. 1560    CONTINUE
  21883.     IF(IFLAG.EQ.1)IFLAG=3
  21884.     LFID(3,N)=CHAR(IFLAG)
  21885. C SETS UP EITHER 1 OR 3 FOR TERMINAL NODES
  21886.     GOTO 1505
  21887. C ESCAPE FROM LOOP ON ENDS...
  21888. 1500    CONTINUE
  21889. C HERE WE RAN OUT OF ROOM. TOO BAD...CAN'T REALLY HELP IT OR
  21890. C DO MUCH. JUST FORGET IT.
  21891. C HOWEVER, PRINT A MESSAGE ON SCREEN AT LEAST...
  21892.     CALL UVT100(1,1,1)
  21893.     CALL SWRT('Formula file overflowed. Try larger file.',41)
  21894. 1505    CONTINUE
  21895. C DONE NOW.
  21896.     GOTO 5000
  21897. 3000    CONTINUE
  21898. C OPEN (CLR BITMAP)
  21899.     MFID(1)=0
  21900.     MFID(2)=0
  21901.     MFBASE=0
  21902.     MFLAST=1
  21903.     GOTO 5000
  21904. 4000    CONTINUE
  21905. C CLOSE (CLR BITMAP)
  21906.     CLOSE(7,STATUS='DELETE')
  21907.     MFBASE=0
  21908.     MFLAST=1
  21909.     MFID(1)=0
  21910.     MFID(2)=0
  21911. 5000    RETURN
  21912.     END
  21913. c -h- xvblgt.f40    Fri Aug 22 13:45:23 1986    
  21914.         SUBROUTINE XVBLGT(ID1,ID2,XX)
  21915. C
  21916. C XVBLGT - LOAD 8 BYTES GIVEN DIMENSIONS FOR GETTING THEM
  21917. C 2 DIM ARRAY, DIM'D (60,301)
  21918.     Include AParms.Inc
  21919.         InTeGer*4 ID1,ID2
  21920.         REAL*8 XX
  21921.     InTeGer*4 TYPE(1,1),VLEN(9)
  21922.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1),VT(8)
  21923.     REAL*8 XXV(1,1),XVT
  21924.     EQUIVALENCE(XVT,VT(1))
  21925.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  21926.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  21927.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  21928.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  21929. C ***<<<< RDD COMMON START >>>***
  21930.     InTeGer*4 RRWACT,RCLACT
  21931. C    COMMON/RCLACT/RRWACT,RCLACT
  21932.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  21933.      1  IDOL7,IDOL8
  21934. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  21935. C     1  IDOL7,IDOL8
  21936.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  21937. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  21938.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21939. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21940. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  21941. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  21942.     InTeGer*4 KLVL
  21943. C    COMMON/KLVL/KLVL
  21944.     InTeGer*4 IOLVL,IGOLD
  21945. C    COMMON/IOLVL/IOLVL
  21946. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  21947. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  21948.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  21949.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  21950.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  21951.      3  k3dfg,kcdelt,krdelt,kpag
  21952. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  21953. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  21954. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  21955. C ***<<< RDD COMMON END >>>***
  21956. CCC        InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21957. CCC        COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21958. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  21959. C NEXT BITMAPS IMPLEMENT FVLD
  21960.         CHARACTER*1 FV1(IMP1S),FV2(Imp1s),FV4(Imp1s)
  21961.     CHARACTER*1 FVXX(Imps3)
  21962.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  21963.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  21964.         Common/FVLDM/FVXX
  21965. c        COMMON/FVLDM/FV1,FV2,FV4
  21966.         CHARACTER*1 LBITS(8)
  21967.         COMMON/BITS/LBITS
  21968. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  21969. C TYPES OF AC'S STORAGE:
  21970.         CHARACTER*1 ITYP(Imp1s),LWK
  21971.         InTeGer*4 IATYP(27)
  21972.     INTEGER*2 LL(4)
  21973.     REAL*8 XA
  21974.     EQUIVALENCE(LL(1),XA)
  21975.         COMMON/TYP/IATYP,ITYP
  21976. C ***<<< NULETC COMMON START >>>***
  21977.     InTeGer*4 ICREF,IRREF
  21978. C    COMMON/MIRROR/ICREF,IRREF
  21979.     InTeGer*4 MODPUB,LIMODE
  21980. C    COMMON/MODPUB/MODPUB,LIMODE
  21981.     InTeGer*4 KLKC,KLKR
  21982.     REAL*8 AACP,AACQ
  21983. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  21984.     InTeGer*4 NCEL,NXINI
  21985. C    COMMON/NCEL/NCEL,NXINI
  21986.     CHARACTER*1 NAMARY(20,MRows)
  21987. C    COMMON/NMNMNM/NAMARY
  21988.     InTeGer*4 NULAST,LFVD
  21989. C    COMMON/NULXXX/NULAST,LFVD
  21990.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  21991.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  21992. C ***<<< NULETC COMMON END >>>***
  21993. CCC    InTeGer*4 ICREF,IRREF
  21994. CCC    COMMON/MIRROR/ICREF,IRREF
  21995.         InTeGer*2 LVALBF(5,MVal)
  21996.         InTeGer*4 MPAG(2),MPMOD(2)
  21997.         COMMON/VB/MPAG,LVALBF,MPMOD
  21998. C
  21999. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  22000. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  22001. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  22002. C AREAS WITH DATA.
  22003. C ***<<< KLSTO COMMON START >>>***
  22004.     InTeGer*4 DLFG
  22005. C    COMMON/DLFG/DLFG
  22006.     InTeGer*4 KDRW,KDCL
  22007. C    COMMON/DOT/KDRW,KDCL
  22008.     InTeGer*4 DTRENA
  22009. C    COMMON/DTRCMN/DTRENA
  22010.     REAL*8 EP,PV,FV
  22011.     DIMENSION EP(20)
  22012.     INTEGER*4 KIRR
  22013. C    COMMON/ERNPER/EP,PV,FV,KIRR
  22014.     InTeGer*4 LASTOP
  22015. C    COMMON/ERROR/LASTOP
  22016.     CHARACTER*1 FMTDAT(9,76)
  22017. C    COMMON/FMTBFR/FMTDAT
  22018.     CHARACTER*1 EDNAM(16)
  22019. C    COMMON/EDNAM/EDNAM
  22020.     InTeGer*4 MFID(2),MFMOD(2)
  22021. C    COMMON/FRM/MFID,MFMOD
  22022.     InTeGer*4 JMVFG,JMVOLD
  22023. C    COMMON/FUBAR/JMVFG,JMVOLD
  22024.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  22025.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  22026. C ***<<< KLSTO COMMON END >>>***
  22027. CCC        CHARACTER*1 FMTDAT(9,76)
  22028. CCC        COMMON/FMTBFR/FMTDAT
  22029.     IF(ID1.GT.27.OR.ID2.GT.1)GOTO 7800
  22030. C AN ACCUMULATOR. GET IT.
  22031.     DO 7801 IV=1,8
  22032. 7801    VT(IV)=AVBLS(IV,ID1)
  22033.     XX=XVT
  22034.     RETURN
  22035. 7800    CONTINUE
  22036. C FILTER OUT TOO-LARGE ID1, ID2 THAT ARE "REFLECTED" UP
  22037. C        ID=(ID2-1)*60+ID1
  22038.     CALL REFLEC(ID2,ID1,ID)
  22039.         XX=0.
  22040. C NOTE THAT HERE IF FVLD IS 0, THIS MEANS RESULT IS 0 REGARDLESS OF
  22041. C OTHER STUFF...RETURN 0 IMMEDIATELY.
  22042. C NOTE TRICK CALL WHICH SIGNALS ANY INITIALIZATION GETS EVALUATED.
  22043.     CALL FVLDGT(ID,0,LWK)
  22044.     IF(ICHAR(LWK).EQ.0)RETURN
  22045. C SET UP HASH CODE NOW FOR THE WAY WE NEED...
  22046.     IBF=(MVal/100)
  22047. C ibf = blk factor
  22048. C    IBF=(800+49)/50/2
  22049. C    IF(IBF.LT.1)IBF=1
  22050. C
  22051.     LLL=(IPGMAX*2)/IBF
  22052.     IPM=LLL
  22053.     IF(IPM.LE.2)IPM=2
  22054.     IHASH=ID
  22055.         JHASH=MOD(IHASH,(MVlov2))+1
  22056.     IF(IPGMOD.NE.0)GOTO 3402
  22057.         IPAG=(IHASH/(MVlov2))+1
  22058.         IPAG=MOD(IPAG,IPM)+1
  22059.     GOTO 3403
  22060. 3402    CONTINUE
  22061. C SPEED-OPTIMIZING PACKING
  22062.     FPG=IPGMOD
  22063. C    IF(FPG.LE.0)FPG=FPG+65536.
  22064.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG
  22065.     IPAG=FPG
  22066.     IPAG=MOD(IPAG,IPM)
  22067.     IPAG=IPAG+1
  22068. C    IPAG=1+(IHASH*IPM)/18060
  22069. 3403    CONTINUE
  22070. C        IF(IPAG.LE.0)IPAG=1
  22071. C TAKE CARE OF EMPTY INITIAL BUFFER...
  22072.     IF(IPAG.EQ.MPAG(1).OR.IPAG.EQ.MPAG(2))GOTO 851
  22073.     IF(MPAG(1).NE.0)GOTO 850
  22074.     MPAG(1)=IPAG
  22075.     GOTO 851
  22076. 850    IF(MPAG(2).EQ.0)MPAG(2)=IPAG
  22077. 851    CONTINUE
  22078.     IF(MPAG(1).EQ.IPAG)GOTO 852
  22079.     IF(MPAG(2).NE.IPAG)GOTO 853
  22080. C MPAG(2)=IPAG
  22081.     MVLAST=2
  22082.     MVBASE=(MVlov2)
  22083.     GOTO 1000
  22084. 852    CONTINUE
  22085.     MVLAST=1
  22086.     MVBASE=0
  22087.     GOTO 1000
  22088. 853    CONTINUE
  22089. C SWITCH BUFFER USED LEAST RECENTLY
  22090.     MVLAST=3-MVLAST
  22091.     MVBASE=MVlov2-MVBASE
  22092. C
  22093. C THE ABOVE ACCOUNTS FOR MEMORY FREE... WE TREAT FILE AS IPM
  22094. C "PAGES" THE SIZE OF THE MEMORY AREA EACH. THIS MAKES IT RELATIVELY
  22095. C EASY TO ALTER THE PROGRAM TO HANDLE MORE MEMORY TO THE EXTENT THE
  22096. C COMPILER AND MACHINE ALLOW.
  22097.     IF(IPGMAX.LE.(MVal/100))GOTO 1000
  22098. C IF HERE, WE NEED A PAGE NOT IN MEMORY. SWAP THE CURRENT MEMORY PAGE
  22099. C TO DISK AND BRING IN THE ONE DESIRED.
  22100. C FILES ARE OPENED ALREADY HERE... USE LUN 9 HERE.
  22101.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  22102.         IRCHI=MPAG(MVLAST)*IBF
  22103.         L=1+MVBASE
  22104.         DO 500 N=IRCLO,IRCHI
  22105.     IF(MPMOD(MVLAST).EQ.0)GOTO 500
  22106.         LLL=L+(MVlo16)-1
  22107.         WRITE(13,REC=N,ERR=500)((LVALBF(KKK,K),KKK=1,5),K=L,LLL)
  22108.         L=L+(MVlo16)
  22109. 500     CONTINUE
  22110.     MPMOD(MVLAST)=0
  22111. C MARK NEW PAGE UNMODIFIED IN THIS READ PROGRAM
  22112.         MPAG(MVLAST)=IPAG
  22113. C NOW READ IN THE DESIRED RECORD, HAVING SET THE DESIRED IN-MEMORY FLAG
  22114.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  22115.         IRCHI=MPAG(MVLAST)*IBF
  22116.         L=1+MVBASE
  22117.         DO 501 N=IRCLO,IRCHI
  22118.         LLL=L+(MVlo16)-1
  22119.         READ(13,REC=N,END=501,ERR=501)((LVALBF(KKK,K),KKK=1,5),K=L,LLL)
  22120.         L=L+(MVlo16)
  22121. 501     CONTINUE
  22122. 1000    CONTINUE
  22123. C NOW THE PAGE NEEDED IS IN MEMORY (OR MAY HAVE BEEN ALL ALONG)
  22124. C SET THE VALUE INTO IT AS REQUIRED...
  22125. C NOW START LOOKING AT HASH ADDRESS FOR VARIABLE...LINEAR SEARCH AFTERWARDS
  22126.         IH1=JHASH-1
  22127.         DO 2 MMN=JHASH,(MVlov2)
  22128.     N=MMN+MVBASE
  22129.     NN=N
  22130. C SKIP OUT IF WE SEE VIRGIN CELLS, LEAVING XX=0.
  22131.     KKKKK=LVALBF(1,N)
  22132.     IF(KKKKK.EQ.-1)GOTO 3332
  22133.         IF(KKKKK.EQ.ID)GOTO 4
  22134. 2       CONTINUE
  22135.         IF(IH1.LT.1)RETURN
  22136.         DO 3 MMN=1,IH1
  22137.     N=MMN+MVBASE
  22138. C LOOK BEFORE THE HASHCODE IF NO FREE CELLS AFTER IT.
  22139.     NN=N
  22140.     KKKKK=LVALBF(1,N)
  22141.     IF(KKKKK.EQ.-1)GOTO 3332
  22142.         IF(KKKKK.EQ.ID)GOTO 4
  22143. 3       CONTINUE
  22144. 3332    XX=0.0
  22145.         RETURN
  22146. C RETURN IF CAN'T FIND VALUE...TOO BAD
  22147. 4       CONTINUE
  22148. C GET VALUE AS 4 16-BIT WORDS
  22149.         DO 5 M=1,4
  22150. 5       LL(M)=LVALBF(M+1,NN)
  22151.         XX=XA
  22152.         RETURN
  22153.         END
  22154. c -h- xvblst.f40    Fri Aug 22 13:45:23 1986    
  22155.         SUBROUTINE XVBLST(ID1,ID2,XX)
  22156. C
  22157. C XVBLST - STORE 8 BYTES IN VARIABLES ARRAY
  22158. C GIVEN DIMENSIONS FOR LOCATING THEM
  22159.     Include AParms.Inc
  22160.         InTeGer*4 ID1,ID2
  22161.     InTeGer*4 TYPE(1,1),VLEN(9)
  22162.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1),VT(8)
  22163.     REAL*8 XVT
  22164.     EQUIVALENCE(VT(1),XVT)
  22165.     REAL*8 XXV(1,1)
  22166.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  22167.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  22168.         REAL*8 XX
  22169. C ***<<<< RDD COMMON START >>>***
  22170.     InTeGer*4 RRWACT,RCLACT
  22171. C    COMMON/RCLACT/RRWACT,RCLACT
  22172.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  22173.      1  IDOL7,IDOL8
  22174. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  22175. C     1  IDOL7,IDOL8
  22176.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  22177. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  22178.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22179. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22180. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  22181. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  22182.     InTeGer*4 KLVL
  22183. C    COMMON/KLVL/KLVL
  22184.     InTeGer*4 IOLVL,IGOLD
  22185. C    COMMON/IOLVL/IOLVL
  22186. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  22187. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  22188.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  22189.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  22190.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  22191.      3  k3dfg,kcdelt,krdelt,kpag
  22192. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  22193. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  22194. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  22195. C ***<<< RDD COMMON END >>>***
  22196. CCC        InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22197. CCC        COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22198. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  22199. C NEXT BITMAPS IMPLEMENT FVLD
  22200.         CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
  22201.     CHARACTER*1 FVXX(IMPS3)
  22202.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  22203.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  22204.         Common/FVLDM/FVXX
  22205. c        COMMON/FVLDM/FV1,FV2,FV4
  22206.         CHARACTER*1 LBITS(8)
  22207.         COMMON/BITS/LBITS
  22208. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  22209. C TYPES OF AC'S STORAGE:
  22210.         CHARACTER*1 ITYP(Imp1s)
  22211. C ***<<< NULETC COMMON START >>>***
  22212.     InTeGer*4 ICREF,IRREF
  22213. C    COMMON/MIRROR/ICREF,IRREF
  22214.     InTeGer*4 MODPUB,LIMODE
  22215. C    COMMON/MODPUB/MODPUB,LIMODE
  22216.     InTeGer*4 KLKC,KLKR
  22217.     REAL*8 AACP,AACQ
  22218. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  22219.     InTeGer*4 NCEL,NXINI
  22220. C    COMMON/NCEL/NCEL,NXINI
  22221.     CHARACTER*1 NAMARY(20,MRows)
  22222. C    COMMON/NMNMNM/NAMARY
  22223.     InTeGer*4 NULAST,LFVD
  22224. C    COMMON/NULXXX/NULAST,LFVD
  22225.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  22226.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  22227. C ***<<< NULETC COMMON END >>>***
  22228. CCC    InTeGer*4 ICREF,IRREF
  22229. CCC    COMMON/MIRROR/ICREF,IRREF
  22230.         InTeGer*4 IATYP(27)
  22231.         COMMON/TYP/IATYP,ITYP
  22232. C
  22233. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  22234. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  22235. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  22236. C AREAS WITH DATA.
  22237.         CHARACTER*1 LLTST
  22238. C ***<<< KLSTO COMMON START >>>***
  22239.     InTeGer*4 DLFG
  22240. C    COMMON/DLFG/DLFG
  22241.     InTeGer*4 KDRW,KDCL
  22242. C    COMMON/DOT/KDRW,KDCL
  22243.     InTeGer*4 DTRENA
  22244. C    COMMON/DTRCMN/DTRENA
  22245.     REAL*8 EP,PV,FV
  22246.     DIMENSION EP(20)
  22247.     INTEGER*4 KIRR
  22248. C    COMMON/ERNPER/EP,PV,FV,KIRR
  22249.     InTeGer*4 LASTOP
  22250. C    COMMON/ERROR/LASTOP
  22251.     CHARACTER*1 FMTDAT(9,76)
  22252. C    COMMON/FMTBFR/FMTDAT
  22253.     CHARACTER*1 EDNAM(16)
  22254. C    COMMON/EDNAM/EDNAM
  22255.     InTeGer*4 MFID(2),MFMOD(2)
  22256. C    COMMON/FRM/MFID,MFMOD
  22257.     InTeGer*4 JMVFG,JMVOLD
  22258. C    COMMON/FUBAR/JMVFG,JMVOLD
  22259.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  22260.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  22261. C ***<<< KLSTO COMMON END >>>***
  22262. CCC        COMMON/FMTBFR/FMTDAT
  22263.         InTeGer*2 LVALBF(5,MVal)
  22264.         InTeGer*4 MPAG(2),MPMOD(2)
  22265.         COMMON/VB/MPAG,LVALBF,MPMOD
  22266.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  22267.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  22268.         InTeGer*2 LL(4)
  22269.         REAL*8 XA
  22270.         EQUIVALENCE(XA,LL(1))
  22271. CCC    InTeGer*4 NCEL,NXINI
  22272. CCC    COMMON/NCEL/NCEL,NXINI
  22273.     IF(ID1.GT.27.OR.ID2.GT.1)GOTO 7800
  22274. C AN ACCUMULATOR. SET IT.
  22275.     XVT=XX
  22276.     DO 7801 IV=1,8
  22277. 7801    AVBLS(IV,ID1)=VT(IV)
  22278.     RETURN
  22279. 7800    CONTINUE
  22280. C        ID=(ID2-1)*60+ID1
  22281.     CALL REFLEC(ID2,ID1,ID)
  22282. C SET UP HASH CODE NOW FOR THE WAY WE NEED...
  22283. C       IPM=(IPGMAX*200/800)
  22284.     IF(ID.LE.0)RETURN
  22285. C CALL FVLDGT TO TELL IF ANYTHING IS SET FOR THE CELL...
  22286.     CALL FVLDGT(ID1,ID2,LLTST)
  22287.     IF(ICHAR(LLTST).NE.0)GOTO 3419
  22288.     CALL FVLDST(ID1,ID2,Char(252))
  22289. c 252 = -4 to 8 bits
  22290. C TRICK ... SET UP SIGN BIT IN FVLD SO XVBLGT CAN FIND OUT IF
  22291. C VARIABLE HAS EVER BEEN WRITTEN AND EXIT IF NOT. INDEPENDENT OF
  22292. C USUAL SETTING OF FVLD SINCE IT USES "SIGN" BIT ONLY.
  22293. 3419    CONTINUE
  22294.     IBF=(MVal+99)/100
  22295. C    IBF=(800+49)/50/2
  22296. C    IF(IBF.LT.1)IBF=1
  22297.     LLL=IPGMAX*2/ibf
  22298. C 4000 BYTES PER BUFFER (400 CELLS AT 10 PER CELL)
  22299. C    LLL=(IPGMAX*2)/IBF
  22300.     IPM=LLL
  22301.     IF(IPM.LE.2)IPM=2
  22302.     IHASH=ID
  22303.         JHASH=MOD(IHASH,(MVlov2))+1
  22304.     IF(IPGMOD.NE.0)GOTO 3400
  22305. C SPACE-OPTIMIZING PACKING
  22306.         IPAG=(IHASH/(MVlov2))+1
  22307.         IPAG=MOD(IPAG,IPM)+1
  22308.     GOTO 3401
  22309. 3400    CONTINUE
  22310. C SPEED-OPTIMIZING PACKING
  22311.     FPG=FLOAT(IPGMOD)
  22312. C    IF(FPG.LE.0.)FPG=FPG+65536.
  22313.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG
  22314.     IPAG=FPG
  22315.     IPAG=MOD(IPAG,IPM)
  22316.     IPAG=IPAG+1
  22317. C    IPAG=1+(IHASH*IPM)/18060
  22318. 3401    CONTINUE
  22319. C        IF(IPAG.LE.0)IPAG=1
  22320.     IF(IPAG.EQ.MPAG(1).OR.IPAG.EQ.MPAG(2))GOTO 850
  22321.     IF(MPAG(1).NE.0)GOTO 851
  22322.     MPAG(1)=IPAG
  22323.     GOTO 850
  22324. 851    IF(MPAG(2).EQ.0)MPAG(2)=IPAG
  22325. 850    CONTINUE
  22326.     IF(MPAG(1).EQ.IPAG)GOTO 852
  22327.     IF(MPAG(2).NE.IPAG)GOTO 853
  22328. C MPAG(2) = IPAG
  22329.     MVLAST=2
  22330.     MVBASE=(MVlov2)
  22331.     GOTO 1000
  22332. 852    CONTINUE
  22333.     MVLAST=1
  22334.     MVBASE=0
  22335.     GOTO 1000
  22336. 853    CONTINUE
  22337. C NEED NEW PAGE. FIX TO USE LEAST RECENTLY USED PAGE FOR SWAPOUT.
  22338.     MVLAST=3-MVLAST
  22339. C MVLAST = 1 OR 2
  22340.     MVBASE=MVlov2-MVBASE
  22341. C MVBASE = 0 OR 400. INITIALLY 0.
  22342. C        IF(MPAG.EQ.0)MPAG=IPAG
  22343. C THE ABOVE ACCOUNTS FOR MEMORY FREE... WE TREAT FILE AS IPM
  22344. C "PAGES" THE SIZE OF THE MEMORY AREA EACH. THIS MAKES IT RELATIVELY
  22345. C EASY TO ALTER THE PROGRAM TO HANDLE MORE MEMORY TO THE EXTENT THE
  22346. C COMPILER AND MACHINE ALLOW.
  22347. c
  22348.     IF(IPGMAX.LE.IBF)GOTO 1000
  22349. c
  22350. C IF HERE, WE NEED A PAGE NOT IN MEMORY. SWAP THE CURRENT MEMORY PAGE
  22351. C TO DISK AND BRING IN THE ONE DESIRED.
  22352. C FILES ARE OPENED ALREADY HERE... USE LUN 9 HERE.
  22353.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  22354.         IRCHI=MPAG(MVLAST)*IBF
  22355.         L=1+MVBASE
  22356.         DO 500 N=IRCLO,IRCHI
  22357.     IF(MPMOD(MVLAST).EQ.0)GOTO 500
  22358.         LLL=L+(MVlo16)-1
  22359.         WRITE(13,REC=N,ERR=500)((LVALBF(KK,K),KK=1,5),K=L,LLL)
  22360.         L=L+(MVlo16)
  22361. 500     CONTINUE
  22362. C MARK NEW PAGE MODIFIED SINCE WE WILL TOUCH IT HERE
  22363.     MPMOD(MVLAST)=1
  22364.         MPAG(MVLAST)=IPAG
  22365. C NOW READ IN THE DESIRED RECORD, HAVING SET THE DESIRED IN-MEMORY FLAG
  22366.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  22367.         IRCHI=MPAG(MVLAST)*IBF
  22368.         L=1+MVBASE
  22369.         DO 501 N=IRCLO,IRCHI
  22370.         LLL=L+(MVlo16)-1
  22371.         READ(13,REC=N,END=501,ERR=501)((LVALBF(KK,K),KK=1,5),K=L,LLL)
  22372.         L=L+(MVlo16)
  22373. 501     CONTINUE
  22374. 1000    CONTINUE
  22375. C NOW THE PAGE NEEDED IS IN MEMORY (OR MAY HAVE BEEN ALL ALONG)
  22376. C SET THE VALUE INTO IT AS REQUIRED...
  22377. C NOW START LOOKING AT HASH ADDRESS FOR VARIABLE...LINEAR SEARCH AFTERWARDS
  22378.     MPMOD(MVLAST)=1
  22379.     IF(NXINI.NE.0)GOTO 111
  22380.         IH1=JHASH-1
  22381.         DO 1 MMN=JHASH,(MVlov2)
  22382.     N=MMN+MVBASE
  22383. C WHILE ZEROING THE ARRAY, START AT THE HASH ADDRESS AND STOP THE ZEROING
  22384. C ONCE WE ENCOUNTER A VIRGIN RECORD. THIS WILL HOPEFULLY REDUCE OVERALL
  22385. C TIME MOST TIMES FOR ZEROING THE ARRAY.
  22386.     KKKKK=LVALBF(1,N)
  22387.     IF(KKKKK.EQ.-1)GOTO 111
  22388.         IF(KKKKK.NE.ID)GOTO 1
  22389. C ZERO ALL REFS TO THIS CELL WE'RE ABOUT TO WRITE.
  22390. C **** THIS IS QUITE TIME CONSUMING... OMIT IF POSSIBLE...
  22391.         LVALBF(1,N)=0
  22392. 1       CONTINUE
  22393.         IF(IH1.LT.1)RETURN
  22394.         DO 33 MMN=1,IH1
  22395.     N=MMN+MVBASE
  22396.     NN=N
  22397.     KKKKK=LVALBF(1,N)
  22398.     IF(KKKKK.EQ.-1)GOTO 111
  22399.         IF(KKKKK.NE.ID)GOTO 33
  22400.     LVALBF(1,N)=0
  22401. 33    CONTINUE
  22402. 111    CONTINUE
  22403. C SINCE ZERO VALUES ARE RETURNED BY DEFAULT, DON'T BOTHER STORING THEM
  22404.     IF(XX.EQ.0.0D0)RETURN
  22405.         IH1=JHASH-1
  22406.         DO 2 MMN=JHASH,(MVlov2)
  22407.     N=MMN+MVBASE
  22408.     NN=N
  22409.     KKKKK=LVALBF(1,N)
  22410.     IF(KKKKK.EQ.-1)GOTO 4
  22411.         IF(KKKKK.EQ.0)GOTO 4
  22412.     IF(KKKKK.EQ.ID)GOTO 4
  22413. 2       CONTINUE
  22414.         IF(IH1.LT.1)RETURN
  22415.         DO 3 MMN=1,IH1
  22416.     N=MMN+MVBASE
  22417.     NN=N
  22418. C LOOK BEFORE THE HASHCODE IF NO FREE CELLS AFTER IT.
  22419.     KKKKK=LVALBF(1,N)
  22420.     IF(KKKKK.EQ.-1)GOTO 4
  22421.         IF(KKKKK.EQ.0)GOTO 4
  22422.     IF(KKKKK.EQ.ID)GOTO 4
  22423. 3       CONTINUE
  22424. C TELL USER VALUE AREA OVERFLOWED, USING ROW 1 END
  22425.     CALL UVT100(1,1,1)
  22426.     CALL SWRT('Value Table Storage overflowed. Try larger file.',48)
  22427.         RETURN
  22428. C RETURN IF CAN'T FIND VALUE...TOO BAD
  22429.  
  22430. 4       CONTINUE
  22431. C SAVE VALUE AS 4 16-BIT WORDS
  22432.         XA=XX
  22433. C SAVE ID AND VALUE IN CELL...
  22434.     LVALBF(1,NN)=ID
  22435.         DO 5 M=1,4
  22436. 5       LVALBF(M+1,NN)=LL(M)
  22437.         RETURN
  22438.         END
  22439. c -h- zero.for    Fri Aug 22 13:46:23 1986    
  22440.     SUBROUTINE ZERO
  22441. C COPYRIGHT (C) 1983 GLENN EVERHART
  22442. C ALL RIGHTS RESERVED
  22443. C 60=MAX REAL ROWS
  22444. C 301=MAX REAL COLS
  22445. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  22446. C VBLS AND TYPE DIMENSIONED 60,301
  22447. C **************************************************
  22448. C *                                                *
  22449. C *         SUBROUTINE  ZERO                       *
  22450. C *                                                *
  22451. C **************************************************
  22452. C
  22453. C
  22454. C
  22455. C  ZEROS OUT ALL VARIABLES EXCEPT %
  22456. C
  22457. C
  22458. C ZERO CALLS IABS
  22459. C
  22460. C
  22461. C ZERO IS CALLED BY CMND
  22462. C
  22463. C
  22464. C
  22465. C   VARIABLE    USE
  22466. C
  22467. C      I      POINTS TO VARIABLE
  22468. C      J      INDEXES DOWN ELEMENTS OF A VARIABLE
  22469. C
  22470. C
  22471. C
  22472. C    SUBROUTINE ZERO
  22473. C
  22474.     InTeGer*4  TYPE(1,1),VLEN(9)
  22475. C
  22476.     CHARACTER*1  AVBLS(20,27)
  22477.     CHARACTER*1 VBLS(8,1,1)
  22478. C
  22479.     COMMON  /V/TYPE,AVBLS,VBLS,VLEN
  22480. C
  22481. C
  22482. C
  22483. C JUST ZERO THE ACCUMULATORS HERE ... LEAVE REGULAR SHEET STUFF ALONE.
  22484. C    TYPE(1,1)=IABS(TYPE(1,1))
  22485.     VBLS(1,1,1)=Char(0)
  22486. C ZERO OUT ACCUMULATORS
  22487.     DO 1 I=1,27
  22488.     DO 1 J=1,20
  22489. 1    AVBLS(J,I)=Char(0)
  22490.     RETURN
  22491.     END
  22492. c -h- zneg.for    Fri Aug 22 13:46:23 1986    
  22493.     INTEGER FUNCTION ZNEG(INDXX)
  22494. C COPYRIGHT (C) 1983 GLENN EVERHART
  22495. C ALL RIGHTS RESERVED
  22496. C 60=MAX REAL ROWS
  22497. C 301=MAX REAL COLS
  22498. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  22499. C VBLS AND TYPE DIMENSIONED 60,301
  22500. C **************************************************
  22501. C *                                                *
  22502. C *        InTeGer*4 FUNCTION ZNEG(INDXX)          *
  22503. C *                                                *
  22504. C **************************************************
  22505. C
  22506. C DETERMINES IF VARIABLE POINTED TO BY INDXX IS ZERO OR NEGATIVE
  22507. C OR UNDEFINED AS OPPOSED TO BEING DEFINED AND POSITIVE
  22508. C
  22509. C     RETURNS      1   IF TRUE (ZERO OR NEGATIVE OR UNDEFINED)
  22510. C                  0   IF FALSE (POSITIVE)
  22511. C
  22512. C ZNEG CALLS ERRMSG TO PRINT ERROR MESSAGES.
  22513. C
  22514. C ZNEG IS CALLED BY CALC AND CMND.
  22515. C
  22516. C   VARIABLE       USE
  22517. C
  22518. C     INDXX      POINTER TO VARIABLE BEING TESTED
  22519. C     I,K        HOLDS TEMPORARY VALUES
  22520. C     ZNEG       RETURN VALUE
  22521. C     INT        HOLD INTEGER*4 VALUES
  22522. C     REAL       HOLD REAL*8 VALUES
  22523. C
  22524. C
  22525. C
  22526. C    INTEGER FUNCTION ZNEG*4(INDXX)
  22527.     REAL*8 REAL
  22528. C
  22529.     INTEGER*4 INT
  22530. C
  22531.     InTeGer*4 TYPE(1,1),VLEN(9),INDXX
  22532. C
  22533.     CHARACTER*1 AVBLS(20,27),FOUR(4),EIGHT(8)
  22534.     CHARACTER*1 VBLS(8,1,1)
  22535. C
  22536.     EQUIVALENCE (EIGHT,REAL),(FOUR,INT)
  22537. C
  22538.     COMMON/V/ TYPE,AVBLS,VBLS,VLEN
  22539. C
  22540. C DEFAULT SETTING OF TRUE
  22541.     ZNEG=1
  22542.     CALL TYPGET(INDXX,1,K)
  22543. C    K=TYPE(INDXX,1)
  22544.     IF(K.GT.0)GO TO 50
  22545. C
  22546. C VARIABLE UNDEFINED
  22547.     CALL UVT100(1,1,1)
  22548.     CALL SWRT('Undefined Vbl',13)
  22549. C    CALL ERRMSG(16)
  22550.     GO TO 10000
  22551. C
  22552. 50    GOTO(100,200,300,300,400,400,400,300,200),K
  22553.     STOP 50
  22554. C
  22555. C ASCII
  22556. 100    IF(AVBLS(1,INDXX).LE.Char(0))GO TO 10000
  22557.     GO TO 9998
  22558. C
  22559. C DECIMAL AND REAL
  22560. 200    DO 210 I=1,8
  22561. 210    EIGHT(I)=AVBLS(I,INDXX)
  22562.     IF(REAL.LE.0.0D0)GO TO 10000
  22563.     GO TO 9998
  22564. C
  22565. C INTEGER, HEX, AND OCTAL
  22566. 300    DO 310 I=1,4
  22567. 310    FOUR(I)=AVBLS(I,INDXX)
  22568.     IF(INT.LE.0)GO TO 10000
  22569.     GO TO 9998
  22570. C
  22571. C MULTIPLE PRECISION
  22572. 400    IF(ICHAR(AVBLS(20,INDXX)).NE.0) GOTO 10000
  22573.     GO TO 9998
  22574. C
  22575. 9998    ZNEG=0
  22576. 10000    RETURN
  22577.     END
  22578.